\ submit-paste [ paste-list ] define-redirect
-"pastebin" "paste-list" "contrib/furnace-pastebin" web-app
-
: annotate-paste ( paste# summary author contents -- )
<annotation> swap get-paste paste-annotations push ;
} define-action
\ annotate-paste [ "n" show-paste ] define-redirect
+
+"pastebin" "paste-list" "contrib/furnace-pastebin" web-app
PROVIDE: contrib/furnace {
"validator.factor"
"responder.factor"
+ "tools/help.factor"
+ "tools/browser.factor"
} {
"test/validator.factor"
"test/responder.factor"
: action-link ( query action -- url )
[
- "/responder/" % "responder" get % "/" %
+ "/responder/" %
+ dup word-vocabulary "furnace:" ?head drop %
+ "/" %
word-name %
] "" make swap build-url ;
--- /dev/null
+! Copyright (C) 2004 Chris Double
+! Copyright (C) 2004, 2006 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+IN: furnace:browser
+USING: definitions hashtables help html httpd io kernel memory
+namespaces prettyprint sequences words xml furnace arrays ;
+
+: option ( current text -- )
+ #! Output the HTML option tag for the given text. If
+ #! it is equal to the current string, make the option selected.
+ <option tuck = [ "selected" =selected ] when option>
+ write
+ </option> ;
+
+: options ( current seq -- ) [ option ] each-with ;
+
+: list ( current seq name -- )
+ <select =name "width: 200px;" =style "20" =size
+ "JavaScript:document.getElementById('main').submit();" =onchange
+ select>
+ options
+ </select> ;
+
+: current-vocab ( -- string )
+ "vocab" query-param [ "kernel" ] unless* ;
+
+: current-word ( -- word )
+ "word" query-param "vocab" query-param lookup ;
+
+: vocab-list ( vocab -- ) vocabs "vocab" list ;
+
+: word-list ( word vocab -- )
+ [ lookup [ word-name ] [ f ] if* ] keep
+ vocab hash-keys natural-sort "word" list ;
+
+: word-source ( -- )
+ #! Write the source for the given word from the vocab as HTML.
+ current-word [ see-help ] when* ;
+
+: browser-body ( word vocab -- )
+ #! Write out the HTML for the body of the main browser page.
+ <table "100%" =width table>
+ <tr>
+ <th> "Vocabularies" write </th>
+ <th> "Words" write </th>
+ <th> "Documentation" write </th>
+ </tr>
+ <tr>
+ <td "top" =valign "width: 200px;" =style td>
+ dup vocab-list
+ </td>
+ <td "top" =valign "width: 200px;" =style td>
+ word-list
+ </td>
+ <td "top" =valign td> word-source </td>
+ </tr>
+ </table> ;
+
+: browser-title ( word vocab -- str )
+ 2dup lookup dup
+ [ 2nip summary ] [ drop nip "IN: " swap append ] if ;
+
+: browse ( word vocab -- )
+ #! Display a Smalltalk like browser for exploring words.
+ 2dup browser-title [
+ [
+ <form "main" =id "browse" =action "get" =method form>
+ browser-body
+ </form>
+ ] with-html-stream
+ ] html-document ;
+
+\ browse {
+ { "word" }
+ { "vocab" "kernel" v-default }
+} define-action
+
+"browser" "browse" "contrib/furnace" web-app
+
+M: word browser-link-href
+ dup word-name swap word-vocabulary \ browse
+ 3array >quotation quot-link ;
--- /dev/null
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: furnace:help
+USING: furnace help html kernel sequences words strings ;
+
+: string>topic ( string -- topic )
+ " " split dup length 1 = [ first ] when ;
+
+: show-help ( topic -- )
+ dup article-title [
+ [ help ] with-html-stream
+ ] html-document ;
+
+\ show-help {
+ { "topic" "handbook" v-default string>topic }
+} define-action
+
+"help" "show-help" "contrib/furnace" web-app
+
+M: link browser-link-href
+ link-name [ \ f ] unless* dup word? [
+ browser-link-href
+ ] [
+ dup [ string? ] all? [ " " join ] when
+ [ show-help ] curry quot-link
+ ] if ;
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-IN: browser-responder
-USING: definitions hashtables help html httpd io kernel memory
-namespaces prettyprint sequences words xml ;
-
-: option ( current text -- )
- #! Output the HTML option tag for the given text. If
- #! it is equal to the current string, make the option selected.
- <option tuck = [ "yes" =selected ] when option>
- chars>entities write
- </option> ;
-
-: options ( current seq -- ) [ option ] each-with ;
-
-: list ( current seq name -- )
- <select =name "width: 200px;" =style "20" =size "document.forms.main.submit()" =onchange select>
- options
- </select> ;
-
-: current-vocab ( -- string )
- "vocab" query-param [ "kernel" ] unless* ;
-
-: current-word ( -- word )
- "word" query-param "vocab" query-param lookup ;
-
-: vocab-list ( -- )
- current-vocab vocabs "vocab" list ;
-
-: word-list ( -- )
- current-word [ word-name ] [ f ] if*
- current-vocab vocab hash-keys natural-sort "word" list ;
-
-: word-source ( -- )
- #! Write the source for the given word from the vocab as HTML.
- current-word [ [ see-help ] with-html-stream ] when* ;
-
-: browser-body ( -- )
- #! Write out the HTML for the body of the main browser page.
- <table "100%" =width table>
- <tr>
- <th> "Vocabularies" write </th>
- <th> "Words" write </th>
- <th> "Documentation" write </th>
- </tr>
- <tr>
- <td "top" =valign "width: 200px;" =style td>
- vocab-list
- </td>
- <td "top" =valign "width: 200px;" =style td>
- word-list
- </td>
- <td "top" =valign td> word-source </td>
- </tr>
- </table> ;
-
-: browser-title ( -- str )
- current-word
- [ summary ] [ "IN: " current-vocab append ] if* ;
-
-: browser-responder ( -- )
- #! Display a Smalltalk like browser for exploring words.
- serving-html browser-title [
- <form "main" =name "" =action "get" =method form>
- browser-body
- </form>
- ] html-document ;
+++ /dev/null
-USING: httpd io kernel namespaces sequences xml ;
-
-SYMBOL: darcs-directory
-
-"/var/www/factorcode.org/repos/" darcs-directory set
-
-: darcs-changelog
- darcs-directory get cd
- "darcs changes --xml" "r" <process-stream> contents xml ;
-
-: rss-item ( { title date author } -- )
- "item" [ ] [
- { "title" "pubDate" "author" } [ [ ] text-tag ] 2each
- ] tag ;
-
-: ?tag-name ( tag -- name/f )
- dup tag? [ tag-name ] [ drop f ] if ;
-
-: children-named ( tag name -- seq )
- swap tag-children [ ?tag-name = ] subset-with ;
-
-: tag-child ( tag name -- tag )
- children-named first ;
-
-: patch>rss-item ( tag -- { title link author date } )
- [
- dup "name" tag-child tag-children %
- tag-props [ "local_date" get , "author" get , ] bind
- ] { } make ;
-
-SYMBOL: rss-feed-title
-SYMBOL: rss-feed-link
-SYMBOL: rss-feed-description
-
-"Factor DARCS repository" rss-feed-title set
-"http://factorcode.org/repos/" rss-feed-link set
-"Recent patches applied to the Factor DARCS repository" rss-feed-description set
-
-: rss-metadata ( -- )
- { rss-feed-title rss-feed-link rss-feed-description }
- { "title" "link" "description" }
- [ >r get r> [ ] text-tag ] 2each ;
-
-: rss-feed ( items -- string )
- [
- "rss" [ "2.0" "version" set ] [
- "channel" [ ] [ rss-metadata [ rss-item ] each ] tag
- ] tag
- ] make-xml xml>string ;
-
-: changelog>rss-feed ( xml -- string )
- "patch" children-named [ patch>rss-item ] map rss-feed ;
-
-: darcs-rss-feed darcs-changelog changelog>rss-feed print ;
-
-"darcs" [ darcs-rss-feed ] add-simple-responder
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: httpd
-USING: browser-responder callback-responder file-responder
-help-responder inspect-responder io kernel namespaces
-prettyprint ;
+USING: callback-responder file-responder io kernel namespaces ;
#! Remove all existing responders, and create a blank
#! responder table.
! 404 error message pages are served by this guy
"404" [ no-such-responder ] add-simple-responder
-
- ! Online help browsing
- "help" [ help-responder ] add-simple-responder
! Used by other responders
"callback" [ callback-responder ] add-simple-responder
] with-scope
] add-simple-responder
- ! Global variables
- "inspector" [ inspect-responder ] add-simple-responder
-
- ! Servers Factor word definitions from the image.
- "browser" [ browser-responder ] add-simple-responder
-
! Serves files from a directory stored in the "doc-root"
! variable. You can set the variable in the global namespace,
! or inside the responder.
+++ /dev/null
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: help-responder
-USING: hashtables help html httpd io kernel namespaces sequences ;
-
-: help-topic
- "topic" query-param dup empty? [ drop "handbook" ] when ;
-
-: help-responder ( -- )
- serving-html
- help-topic dup article-title [
- [ help ] with-html-stream
- ] html-document ;
: define-attribute-word ( name -- )
dup "=" swap append swap
- [ , [ write-attr ] % ] [ ] make html-word drop ;
+ [ write-attr ] curry html-word drop ;
! Define some closed HTML tags
[
M: object browser-link-href drop f ;
-M: word browser-link-href
- "/responder/browser/" swap [
- dup word-vocabulary "vocab" set word-name "word" set
- ] make-hash build-url ;
-
-M: link browser-link-href
- link-name [ \ f ] unless* dup word? [
- browser-link-href
- ] [
- "/responder/help/" swap "topic" associate build-url
- ] if ;
-
: resolve-file-link ( path -- link )
#! The file responder needs relative links not absolute
#! links.
: default-css ( -- )
<style "text/css" =type style>
- "A:link { text-decoration: none; color: black; }" print
- "A:visited { text-decoration: none; color: black; }" print
- "A:active { text-decoration: none; color: black; }" print
- "A:hover, A:hover { text-decoration: underline; color: black; }" print
+ "a:link { text-decoration: none; color: black; }" print
+ "a:visited { text-decoration: none; color: black; }" print
+ "a:active { text-decoration: none; color: black; }" print
+ "a:hover, A:hover { text-decoration: underline; color: black; }" print
</style> ;
: xhtml-preamble
+++ /dev/null
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: inspect-responder
-USING: callback-responder generic hashtables help html httpd
-tools kernel namespaces prettyprint sequences ;
-
-! Mini object inspector
-: http-inspect ( obj -- )
- dup summary [ describe ] simple-html-document ;
-
-M: general-t browser-link-href
- [ http-inspect ] curry t register-html-callback ;
-
-: inspect-responder ( url -- )
- serving-html global http-inspect ;
"prototype-js.factor"
"html.factor"
"file-responder.factor"
- "help-responder.factor"
- "inspect-responder.factor"
- "browser-responder.factor"
"default-responders.factor"
} {
"test/html.factor"
projects / factor.git / commitdiff