Merge git://factorcode.org/git/factor
Doug Coleman
commit
6470303e51
|
|
@ -16,9 +16,10 @@ M: object inference-error-major? drop t ;
|
|||
|
||||
: begin-batch ( seq -- )
|
||||
batch-mode on
|
||||
[
|
||||
"Compiling " % length # " words..." %
|
||||
] "" make print flush
|
||||
"quiet" get [ drop ] [
|
||||
[ "Compiling " % length # " words..." % ] "" make
|
||||
print flush
|
||||
] if
|
||||
V{ } clone compile-errors set-global ;
|
||||
|
||||
: compile-error. ( pair -- )
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ USING: kernel vectors io assocs quotations splitting strings
|
|||
continuations tuples classes io.files
|
||||
http http.server.templating http.basic-authentication
|
||||
webapps.callback html html.elements
|
||||
http.server.responders furnace.validator ;
|
||||
http.server.responders furnace.validator vocabs ;
|
||||
IN: furnace
|
||||
|
||||
SYMBOL: default-action
|
||||
|
|
@ -101,36 +101,14 @@ SYMBOL: request-params
|
|||
|
||||
: service-post ( url -- ) "response" get swap service-request ;
|
||||
|
||||
: explode-tuple ( tuple -- )
|
||||
dup tuple-slots swap class "slot-names" word-prop
|
||||
[ set ] 2each ;
|
||||
: send-resource ( name -- )
|
||||
template-path get swap path+ resource-path <file-reader>
|
||||
stdio get stream-copy ;
|
||||
|
||||
SYMBOL: model
|
||||
|
||||
: call-template ( model template -- )
|
||||
[
|
||||
>r [ dup model set explode-tuple ] when* r>
|
||||
".furnace" append resource-path run-template-file
|
||||
] with-scope ;
|
||||
|
||||
: render-template ( model template -- )
|
||||
template-path get swap path+ call-template ;
|
||||
|
||||
: render-page* ( model body-template head-template -- )
|
||||
[
|
||||
[ render-template ] [ f rot render-template ] html-document
|
||||
] serve-html ;
|
||||
|
||||
: render-titled-page* ( model body-template head-template title -- )
|
||||
[
|
||||
[ render-template ] swap [ <title> write </title> f rot render-template ] curry html-document
|
||||
] serve-html ;
|
||||
|
||||
|
||||
: render-page ( model template title -- )
|
||||
[
|
||||
[ render-template ] simple-html-document
|
||||
] serve-html ;
|
||||
: render-template ( template -- )
|
||||
template-path get swap path+
|
||||
".furnace" append resource-path
|
||||
run-template-file ;
|
||||
|
||||
: web-app ( name default path -- )
|
||||
[
|
||||
|
|
@ -141,3 +119,22 @@ SYMBOL: model
|
|||
[ service-post ] "post" set
|
||||
! [ service-head ] "head" set
|
||||
] make-responder ;
|
||||
|
||||
: explode-tuple ( tuple -- )
|
||||
dup tuple-slots swap class "slot-names" word-prop
|
||||
[ set ] 2each ;
|
||||
|
||||
SYMBOL: model
|
||||
|
||||
: with-slots ( model quot -- )
|
||||
[
|
||||
>r [ dup model set explode-tuple ] when* r> call
|
||||
] with-scope ;
|
||||
|
||||
: render-component ( model template -- )
|
||||
swap [ render-template ] with-slots ;
|
||||
|
||||
: browse-webapp-source ( vocab -- )
|
||||
<a f >vocab-link browser-link-href =href a>
|
||||
"Browse source" write
|
||||
</a> ;
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ IN: http
|
|||
dup letter?
|
||||
over LETTER? or
|
||||
over digit? or
|
||||
swap "/_?." member? or ; foldable
|
||||
swap "/_-?." member? or ; foldable
|
||||
|
||||
: url-encode ( str -- str )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -87,9 +87,9 @@ TUPLE: CreateProcess-args
|
|||
pass-environment? [
|
||||
[
|
||||
get-environment
|
||||
[ swap % "=" % % "\0" % ] assoc-each
|
||||
[ "=" swap 3append string>u16-alien % ] assoc-each
|
||||
"\0" %
|
||||
] "" make >c-ushort-array
|
||||
] { } make >c-ushort-array
|
||||
over set-CreateProcess-args-lpEnvironment
|
||||
] when ;
|
||||
|
||||
|
|
|
|||
|
|
@ -74,7 +74,7 @@ C: <entry> entry
|
|||
|
||||
: download-feed ( url -- feed )
|
||||
#! Retrieve an news syndication file, return as a feed tuple.
|
||||
http-get rot 200 = [
|
||||
http-get-stream rot 200 = [
|
||||
nip read-feed
|
||||
] [
|
||||
2drop "Error retrieving newsfeed file" throw
|
||||
|
|
@ -84,12 +84,15 @@ C: <entry> entry
|
|||
: simple-tag, ( content name -- )
|
||||
[ , ] tag, ;
|
||||
|
||||
: simple-tag*, ( content name attrs -- )
|
||||
[ , ] tag*, ;
|
||||
|
||||
: entry, ( entry -- )
|
||||
"entry" [
|
||||
dup entry-title "title" simple-tag,
|
||||
dup entry-title "title" { { "type" "html" } } simple-tag*,
|
||||
"link" over entry-link "href" associate contained*,
|
||||
dup entry-pub-date "published" simple-tag,
|
||||
entry-description "content" simple-tag,
|
||||
entry-description "content" { { "type" "html" } } simple-tag*,
|
||||
] tag, ;
|
||||
|
||||
: feed>xml ( feed -- xml )
|
||||
|
|
|
|||
|
|
@ -4,12 +4,17 @@
|
|||
USING: kernel furnace sqlite.tuple-db webapps.article-manager.database
|
||||
sequences namespaces math arrays assocs quotations io.files
|
||||
http.server http.basic-authentication http.server.responders
|
||||
webapps.file ;
|
||||
webapps.file html html.elements io ;
|
||||
IN: webapps.article-manager
|
||||
|
||||
: current-site ( -- site )
|
||||
host get-site* ;
|
||||
|
||||
: render-titled-page* ( model body-template head-template title -- )
|
||||
[
|
||||
[ render-component ] swap [ <title> write </title> f rot render-component ] curry html-document
|
||||
] serve-html ;
|
||||
|
||||
TUPLE: template-args arg1 ;
|
||||
|
||||
C: <template-args> template-args
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database html.elements ; %>
|
||||
<div id="banner"><h1><% "arg1" get second article-title write %></h1></div>
|
||||
<% f "navigation" render-template %>
|
||||
<% "navigation" render-template %>
|
||||
<div id="article">
|
||||
<% 100 random 25 > [ "arg1" get first 100 random 50 > [ site-ad2 ] [ site-ad3 ] if write-html ] when %>
|
||||
<% "arg1" get second article-body write-html %>
|
||||
|
||||
<h1>Tags</h1>
|
||||
<% "arg1" get second tags-for-article <template-args> "tags" render-template %>
|
||||
<% "arg1" get second tags-for-article <template-args> "tags" render-component %>
|
||||
</div>
|
||||
<p class="footer"></p>
|
||||
<p id="copyright"><% "arg1" get first site-footer write %></p>
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
</head>
|
||||
<body>
|
||||
<div id="banner"><h1><% "title" get write %></h1></div>
|
||||
<% f "navigation" render-template %>
|
||||
<% "navigation" render-template %>
|
||||
<div id="article">
|
||||
<% "intro" get write-html %>
|
||||
<h1>Recent Articles</h1>
|
||||
|
|
@ -23,7 +23,7 @@
|
|||
but in the meantime, Google is likely to provide
|
||||
reasonable results.
|
||||
</p>
|
||||
<% host all-tags <template-args> "tags" render-template %>
|
||||
<% host all-tags <template-args> "tags" render-component %>
|
||||
</div>
|
||||
<p class="footer"></p>
|
||||
<p id="copyright"><% "footer" get write %></p>
|
||||
|
|
|
|||
|
|
@ -5,5 +5,5 @@
|
|||
</ul>
|
||||
<% current-site site-ad1 write-html %>
|
||||
<h1>Tags</h1>
|
||||
<% host all-tags <template-args> "tags" render-template %>
|
||||
<% host all-tags <template-args> "tags" render-component %>
|
||||
</div>
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %>
|
||||
|
||||
<div id="banner"><h1><% "arg1" get second tag-title write %></h1></div>
|
||||
<% f "navigation" render-template %>
|
||||
<% "navigation" render-component %>
|
||||
<div id="article">
|
||||
<h1><% "arg1" get second tag-title write %></h1>
|
||||
<% "arg1" get second tag-description write-html %>
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2006 Slava Pestov.
|
||||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: calendar html io io.files kernel math math.parser
|
||||
http.server.responders http.server.templating namespaces parser
|
||||
|
|
@ -31,15 +31,23 @@ IN: webapps.file
|
|||
"304 Not Modified" response
|
||||
now timestamp>http-string "Date" associate print-header ;
|
||||
|
||||
! You can override how files are served in a custom responder
|
||||
SYMBOL: serve-file-hook
|
||||
|
||||
[
|
||||
file-response
|
||||
stdio get stream-copy
|
||||
] serve-file-hook set-global
|
||||
|
||||
: serve-static ( filename mime-type -- )
|
||||
over last-modified-matches? [
|
||||
2drop not-modified-response
|
||||
] [
|
||||
dupd file-response
|
||||
"method" get "head" = [
|
||||
drop
|
||||
file-response
|
||||
] [
|
||||
<file-reader> stdio get stream-copy
|
||||
>r dup <file-reader> swap r>
|
||||
serve-file-hook get call
|
||||
] if
|
||||
] if ;
|
||||
|
||||
|
|
@ -53,9 +61,13 @@ SYMBOL: page
|
|||
: include-page ( filename -- )
|
||||
"doc-root" get swap path+ run-page ;
|
||||
|
||||
: serve-fhtml ( filename -- )
|
||||
serving-html
|
||||
"method" get "head" = [ drop ] [ run-page ] if ;
|
||||
|
||||
: serve-file ( filename -- )
|
||||
dup mime-type dup "application/x-factor-server-page" =
|
||||
[ drop serving-html run-page ] [ serve-static ] if ;
|
||||
[ drop serve-fhtml ] [ serve-static ] if ;
|
||||
|
||||
: file. ( name dirp -- )
|
||||
[ "/" append ] when
|
||||
|
|
@ -107,7 +119,7 @@ SYMBOL: page
|
|||
|
||||
global [
|
||||
! Serve up our own source code
|
||||
"resources" [
|
||||
"resources" [
|
||||
[
|
||||
"" resource-path "doc-root" set
|
||||
file-responder
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
USING: kernel furnace fjsc parser-combinators namespaces
|
||||
lazy-lists io io.files furnace.validator sequences
|
||||
http.client http.server http.server.responders
|
||||
webapps.file ;
|
||||
webapps.file html ;
|
||||
IN: webapps.fjsc
|
||||
|
||||
: compile ( code -- )
|
||||
|
|
@ -31,6 +31,11 @@ IN: webapps.fjsc
|
|||
{ "url" v-required }
|
||||
} define-action
|
||||
|
||||
: render-page* ( model body-template head-template -- )
|
||||
[
|
||||
[ render-component ] [ f rot render-component ] html-document
|
||||
] serve-html ;
|
||||
|
||||
: repl ( -- )
|
||||
#! The main 'repl' page.
|
||||
f "repl" "head" render-page* ;
|
||||
|
|
|
|||
|
|
@ -82,4 +82,4 @@ PREDICATE: pathname resource-pathname
|
|||
M: resource-pathname browser-link-href
|
||||
pathname-string
|
||||
"resource:" ?head drop
|
||||
"/responder/resources/" swap append ;
|
||||
"/responder/source/" swap append ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
<% USING: io math math.parser namespaces ; %>
|
||||
<% USING: io math math.parser namespaces furnace ; %>
|
||||
|
||||
<h1>Annotate</h1>
|
||||
|
||||
|
|
@ -9,17 +9,22 @@
|
|||
<input type="hidden" name="n" value="<% "n" get number>string write %>" />
|
||||
|
||||
<tr>
|
||||
<th>Your name:</th>
|
||||
<td><input type="TEXT" name="author" value="" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th>Summary:</th>
|
||||
<th align="right">Summary:</th>
|
||||
<td><input type="TEXT" name="summary" value="" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th valign="top">Contents:</th>
|
||||
<th align="right">Your name:</th>
|
||||
<td><input type="TEXT" name="author" value="" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th align="right">File type:</th>
|
||||
<td><% "modes" render-template %></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th align="right" valign="top">Content:</th>
|
||||
<td><textarea rows="24" cols="60" name="contents"></textarea></td>
|
||||
</tr>
|
||||
</table>
|
||||
|
|
|
|||
|
|
@ -8,4 +8,4 @@
|
|||
<tr><th>Created:</th><td><% "date" get write %></td></tr>
|
||||
</table>
|
||||
|
||||
<pre><% "contents" get write %></pre>
|
||||
<% "syntax" render-template %>
|
||||
|
|
|
|||
|
|
@ -0,0 +1,3 @@
|
|||
</body>
|
||||
|
||||
</html>
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
<% 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>
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
<% USING: xmode.catalog sequences kernel html.elements assocs io sorting ; %>
|
||||
|
||||
<select name="mode">
|
||||
<% modes keys natural-sort [
|
||||
<option dup "factor" = [ "true" =selected ] when option> write </option>
|
||||
] each %>
|
||||
</select>
|
||||
|
|
@ -1,27 +1,41 @@
|
|||
<% USING: furnace namespaces ; %>
|
||||
|
||||
<%
|
||||
"new paste" "title" set
|
||||
"header" render-template
|
||||
%>
|
||||
|
||||
<form method="POST" action="/responder/pastebin/submit-paste">
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th>Your name:</th>
|
||||
<td><input type="TEXT" name="author" value="" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th>Summary:</th>
|
||||
<th align="right">Summary:</th>
|
||||
<td><input type="TEXT" name="summary" value="" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th>Channel:</th>
|
||||
<th align="right">Your name:</th>
|
||||
<td><input type="TEXT" name="author" value="" /></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>
|
||||
<th valign="top">Contents:</th>
|
||||
<th align="right" valign="top">Content:</th>
|
||||
<td><textarea rows="24" cols="60" name="contents"></textarea></td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
<input type="SUBMIT" value="Submit paste" />
|
||||
</form>
|
||||
|
||||
<% "footer" render-template %>
|
||||
|
|
|
|||
|
|
@ -1,7 +1,31 @@
|
|||
<% USING: namespaces furnace sequences ; %>
|
||||
|
||||
<table width="100%">
|
||||
<% "new-paste-quot" get "New paste" render-link %>
|
||||
<tr align="left"><th> </th><th>Summary:</th><th>Paste by:</th><th>Link</th><th>Date</th></tr>
|
||||
<% "pastes" get <reversed> [ "paste-summary" render-template ] each %></table>
|
||||
<%
|
||||
"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%" 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>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
<% "footer" render-template %>
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
<% USING: continuations namespaces io kernel math math.parser furnace ; %>
|
||||
<% USING: continuations namespaces io kernel math math.parser furnace webapps.pastebin ; %>
|
||||
|
||||
<tr>
|
||||
<td><% "n" get number>string write %></td>
|
||||
<td><% "summary" get write %></td>
|
||||
<td><% "author" get write %></td>
|
||||
<td><% "n" get number>string "show-paste-quot" get curry "Show" render-link %></td>
|
||||
<td><% "date" get print %></td>
|
||||
<td>
|
||||
<a href="<% model get paste-link write %>">
|
||||
<% "summary" get write %>
|
||||
</a>
|
||||
</td>
|
||||
<td><% "author" get write %></td>
|
||||
<td><% "date" get print %></td>
|
||||
</tr>
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: calendar furnace furnace.validator io.files kernel namespaces
|
||||
sequences store ;
|
||||
USING: calendar furnace furnace.validator io.files kernel
|
||||
namespaces sequences store http.server.responders html
|
||||
math.parser rss xml.writer ;
|
||||
IN: webapps.pastebin
|
||||
|
||||
TUPLE: pastebin pastes ;
|
||||
|
|
@ -7,23 +8,17 @@ TUPLE: pastebin pastes ;
|
|||
: <pastebin> ( -- pastebin )
|
||||
V{ } clone pastebin construct-boa ;
|
||||
|
||||
TUPLE: paste n summary article author channel contents date annotations ;
|
||||
TUPLE: paste
|
||||
summary author channel mode contents date
|
||||
annotations n ;
|
||||
|
||||
: <paste> ( summary author channel contents -- paste )
|
||||
V{ } clone
|
||||
{
|
||||
set-paste-summary
|
||||
set-paste-author
|
||||
set-paste-channel
|
||||
set-paste-contents
|
||||
set-paste-annotations
|
||||
} paste construct ;
|
||||
: <paste> ( summary author channel mode contents -- paste )
|
||||
f V{ } clone f paste construct-boa ;
|
||||
|
||||
TUPLE: annotation summary author contents ;
|
||||
TUPLE: annotation summary author mode contents ;
|
||||
|
||||
C: <annotation> annotation
|
||||
|
||||
|
||||
SYMBOL: store
|
||||
|
||||
"pastebin.store" resource-path load-store store set-global
|
||||
|
|
@ -34,35 +29,56 @@ SYMBOL: store
|
|||
pastebin get pastebin-pastes nth ;
|
||||
|
||||
: show-paste ( n -- )
|
||||
get-paste "show-paste" "Paste" render-page ;
|
||||
serving-html
|
||||
get-paste
|
||||
[ "show-paste" render-component ] with-html-stream ;
|
||||
|
||||
\ show-paste { { "n" v-number } } define-action
|
||||
|
||||
: new-paste ( -- )
|
||||
f "new-paste" "New paste" render-page ;
|
||||
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" "Pastebin" render-page
|
||||
] with-scope ;
|
||||
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 ;
|
||||
|
||||
: paste-feed ( -- entries )
|
||||
pastebin get pastebin-pastes [
|
||||
{
|
||||
paste-summary
|
||||
paste-link
|
||||
paste-date
|
||||
} get-slots "" 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
|
||||
|
||||
: save-pastebin-store ( -- )
|
||||
store get-global save-store ;
|
||||
|
||||
: add-paste ( paste pastebin -- )
|
||||
>r now timestamp>http-string over set-paste-date r>
|
||||
pastebin-pastes
|
||||
[ length over set-paste-n ] keep push ;
|
||||
pastebin-pastes 2dup length swap set-paste-n push ;
|
||||
|
||||
: submit-paste ( summary author channel contents -- )
|
||||
: submit-paste ( summary author channel mode contents -- )
|
||||
<paste>
|
||||
\ pastebin get-global add-paste
|
||||
save-pastebin-store ;
|
||||
|
|
@ -71,12 +87,13 @@ SYMBOL: store
|
|||
{ "summary" v-required }
|
||||
{ "author" v-required }
|
||||
{ "channel" "#concatenative" v-default }
|
||||
{ "mode" "factor" v-default }
|
||||
{ "contents" v-required }
|
||||
} define-action
|
||||
|
||||
\ submit-paste [ paste-list ] define-redirect
|
||||
|
||||
: annotate-paste ( n summary author contents -- )
|
||||
: annotate-paste ( n summary author mode contents -- )
|
||||
<annotation> swap get-paste
|
||||
paste-annotations push
|
||||
save-pastebin-store ;
|
||||
|
|
@ -85,9 +102,16 @@ SYMBOL: store
|
|||
{ "n" v-required v-number }
|
||||
{ "summary" v-required }
|
||||
{ "author" v-required }
|
||||
{ "mode" "factor" v-default }
|
||||
{ "contents" v-required }
|
||||
} define-action
|
||||
|
||||
\ annotate-paste [ "n" show-paste ] define-redirect
|
||||
|
||||
: style.css ( -- )
|
||||
"text/css" serving-content
|
||||
"style.css" send-resource ;
|
||||
|
||||
\ style.css { } define-action
|
||||
|
||||
"pastebin" "paste-list" "extra/webapps/pastebin" web-app
|
||||
|
|
|
|||
|
|
@ -1,15 +1,21 @@
|
|||
<% USING: namespaces io furnace sequences ; %>
|
||||
<% USING: namespaces io furnace sequences xmode.code2html ; %>
|
||||
|
||||
<h1>Paste: <% "summary" get write %></h1>
|
||||
<%
|
||||
"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 write %></td></tr>
|
||||
<tr><th>File type:</th><td><% "mode" get write %></td></tr>
|
||||
</table>
|
||||
|
||||
<pre><% "contents" get write %></pre>
|
||||
<% "syntax" render-template %>
|
||||
|
||||
<% "annotations" get [ "annotation" render-template ] each %>
|
||||
<% "annotations" get [ "annotation" render-component ] each %>
|
||||
|
||||
<% model get "annotate-paste" render-template %>
|
||||
<% model get "annotate-paste" render-component %>
|
||||
|
||||
<% "footer" render-template %>
|
||||
|
|
|
|||
|
|
@ -0,0 +1,37 @@
|
|||
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;
|
||||
}
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
<% USING: xmode.code2html splitting namespaces ; %>
|
||||
|
||||
<pre class="code"><% "contents" get string-lines "mode" get htmlize-lines %></pre>
|
||||
|
|
@ -1,41 +1,14 @@
|
|||
USING: sequences rss arrays concurrency 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 ;
|
||||
continuations debugger system http.server.responders
|
||||
xml.writer ;
|
||||
IN: webapps.planet
|
||||
|
||||
TUPLE: posting author title date link body ;
|
||||
|
||||
: diagnostic write print flush ;
|
||||
|
||||
: fetch-feed ( pair -- feed )
|
||||
second
|
||||
dup "Fetching " diagnostic
|
||||
dup download-feed feed-entries
|
||||
swap "Done fetching " diagnostic ;
|
||||
|
||||
: fetch-blogroll ( blogroll -- entries )
|
||||
#! entries is an array of { author entries } pairs.
|
||||
dup [
|
||||
[ fetch-feed ] [ error. drop f ] recover
|
||||
] parallel-map
|
||||
[ [ >r first r> 2array ] curry* map ] 2map concat ;
|
||||
|
||||
: sort-entries ( entries -- entries' )
|
||||
[ [ second entry-pub-date ] compare ] sort <reversed> ;
|
||||
|
||||
: <posting> ( pair -- posting )
|
||||
#! pair has shape { author entry }
|
||||
first2
|
||||
{ entry-title entry-pub-date entry-link entry-description }
|
||||
get-slots posting construct-boa ;
|
||||
|
||||
: print-posting-summary ( posting -- )
|
||||
<p "news" =class p>
|
||||
<b> dup posting-title write </b> <br/>
|
||||
"- " write
|
||||
dup posting-author write bl
|
||||
<a posting-link =href "more" =class a>
|
||||
<b> dup entry-title write </b> <br/>
|
||||
<a entry-link =href "more" =class a>
|
||||
"Read More..." write
|
||||
</a>
|
||||
</p> ;
|
||||
|
|
@ -63,58 +36,79 @@ TUPLE: posting author title date link body ;
|
|||
|
||||
: print-posting ( posting -- )
|
||||
<h2 "posting-title" =class h2>
|
||||
<a dup posting-link =href a>
|
||||
dup posting-title write-html
|
||||
" - " write
|
||||
dup posting-author write
|
||||
<a dup entry-link =href a>
|
||||
dup entry-title write-html
|
||||
</a>
|
||||
</h2>
|
||||
<p "posting-body" =class p> dup posting-body write-html </p>
|
||||
<p "posting-date" =class p> posting-date format-date write </p> ;
|
||||
<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 ;
|
||||
|
||||
: browse-webapp-source ( vocab -- )
|
||||
<a f >vocab-link browser-link-href =href a>
|
||||
"Browse source" write
|
||||
</a> ;
|
||||
|
||||
SYMBOL: default-blogroll
|
||||
SYMBOL: cached-postings
|
||||
|
||||
: update-cached-postings ( -- )
|
||||
default-blogroll get fetch-blogroll sort-entries
|
||||
[ <posting> ] map
|
||||
cached-postings set-global ;
|
||||
|
||||
: mini-planet-factor ( -- )
|
||||
cached-postings get 4 head print-posting-summaries ;
|
||||
|
||||
: planet-factor ( -- )
|
||||
serving-html [
|
||||
"resource:extra/webapps/planet/planet.fhtml"
|
||||
run-template-file
|
||||
] with-html-stream ;
|
||||
serving-html [ "planet" render-template ] with-html-stream ;
|
||||
|
||||
\ planet-factor { } define-action
|
||||
|
||||
{
|
||||
{ "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
|
||||
{ "Chris Double" "http://www.bluishcoder.co.nz/atom.xml" "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/" }
|
||||
{ "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
|
||||
: planet-feed ( -- feed )
|
||||
"[ planet-factor ]"
|
||||
"http://planet.factorcode.org"
|
||||
cached-postings get 30 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
|
||||
|
||||
: diagnostic write print flush ;
|
||||
|
||||
: fetch-feed ( triple -- feed )
|
||||
second
|
||||
dup "Fetching " diagnostic
|
||||
dup download-feed feed-entries
|
||||
swap "Done fetching " diagnostic ;
|
||||
|
||||
: <posting> ( author entry -- entry' )
|
||||
clone
|
||||
[ ": " swap entry-title 3append ] keep
|
||||
[ set-entry-title ] keep ;
|
||||
|
||||
: ?fetch-feed ( triple -- feed/f )
|
||||
[ fetch-feed ] [ error. drop f ] recover ;
|
||||
|
||||
: fetch-blogroll ( blogroll -- entries )
|
||||
dup 0 <column>
|
||||
swap [ ?fetch-feed ] parallel-map
|
||||
[ [ <posting> ] curry* 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 ] in-thread
|
||||
|
|
@ -126,14 +120,16 @@ SYMBOL: last-update
|
|||
|
||||
"planet" "planet-factor" "extra/webapps/planet" web-app
|
||||
|
||||
: merge-feeds ( feeds -- feed )
|
||||
[ feed-entries ] map concat sort-entries ;
|
||||
|
||||
: planet-feed ( -- feed )
|
||||
default-blogroll get [ second download-feed ] map merge-feeds
|
||||
>r "[ planet-factor ]" "http://planet.factorcode.org" r> <entry>
|
||||
feed>xml ;
|
||||
|
||||
: feed.xml planet-feed ;
|
||||
|
||||
\ feed.xml { } define-action
|
||||
{
|
||||
{ "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/" }
|
||||
{ "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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
<% USING: namespaces html.elements webapps.planet sequences ; %>
|
||||
<% 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">
|
||||
|
|
@ -8,7 +9,8 @@
|
|||
<meta http-equiv="Content-type" content="text/html; charset=utf-8" />
|
||||
|
||||
<title>planet-factor</title>
|
||||
<link rel="stylesheet" href="/responder/file/css/news.css" type="text/css" media="screen" title="no title" charset="utf-8" />
|
||||
<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">
|
||||
|
|
@ -23,7 +25,11 @@
|
|||
<a href="http://planet.lisp.org">Planet Lisp</a>.
|
||||
</p>
|
||||
<p>
|
||||
This webapp is written in <a href="http://factorcode.org/">Factor</a>.
|
||||
<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>
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
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;
|
||||
}
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files namespaces webapps.file http.server.responders
|
||||
xmode.code2html kernel ;
|
||||
IN: webapps.source
|
||||
|
||||
global [
|
||||
! Serve up our own source code
|
||||
"source" [
|
||||
[
|
||||
"" resource-path "doc-root" set
|
||||
[
|
||||
drop
|
||||
serving-html
|
||||
swap htmlize-stream
|
||||
] serve-file-hook set
|
||||
file-responder
|
||||
] with-scope
|
||||
] add-simple-responder
|
||||
] bind
|
||||
|
|
@ -32,10 +32,10 @@ to depend on:
|
|||
it inherits the value of the NO_WORD_SEP attribute from the previous
|
||||
RULES tag.
|
||||
|
||||
The Factor implementation does not duplicate this behavior.
|
||||
The Factor implementation does not duplicate this behavior. If you
|
||||
find a mode file which depends on this flaw, please fix it and submit
|
||||
the changes to the jEdit project.
|
||||
|
||||
This is still a work in progress. If you find any behavioral differences
|
||||
between the Factor implementation and the original jEdit code, please
|
||||
report them as bugs. Also, if you wish to contribute a new or improved
|
||||
mode file, please contact the jEdit project. Updated mode files in jEdit
|
||||
will be periodically imported into the Factor source tree.
|
||||
If you wish to contribute a new or improved mode file, please contact
|
||||
the jEdit project. Updated mode files in jEdit will be periodically
|
||||
imported into the Factor source tree.
|
||||
|
|
|
|||
|
|
@ -5,5 +5,7 @@ kernel sequences io ;
|
|||
[ t ] [ modes hashtable? ] unit-test
|
||||
|
||||
[ ] [
|
||||
modes keys [ dup print load-mode drop reset-modes ] each
|
||||
modes keys [
|
||||
dup print flush load-mode drop reset-modes
|
||||
] each
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ TAGS>
|
|||
"extra/xmode/modes/catalog" resource-path
|
||||
<file-reader> read-xml parse-modes-tag ;
|
||||
|
||||
: modes ( -- )
|
||||
: modes ( -- assoc )
|
||||
\ modes get-global [
|
||||
load-catalog dup \ modes set-global
|
||||
] unless* ;
|
||||
|
|
|
|||
|
|
@ -15,8 +15,8 @@ IN: xmode.code2html
|
|||
: htmlize-line ( line-context line rules -- line-context' )
|
||||
tokenize-line htmlize-tokens ;
|
||||
|
||||
: htmlize-lines ( lines rules -- )
|
||||
<pre> f -rot [ htmlize-line nl ] curry each drop </pre> ;
|
||||
: htmlize-lines ( lines mode -- )
|
||||
f swap load-mode [ htmlize-line nl ] curry reduce drop ;
|
||||
|
||||
: default-stylesheet ( -- )
|
||||
<style>
|
||||
|
|
@ -24,22 +24,22 @@ IN: xmode.code2html
|
|||
resource-path <file-reader> contents write
|
||||
</style> ;
|
||||
|
||||
: htmlize-stream ( path stream -- )
|
||||
lines swap
|
||||
<html>
|
||||
<head>
|
||||
default-stylesheet
|
||||
<title> dup write </title>
|
||||
</head>
|
||||
<body>
|
||||
<pre>
|
||||
over empty?
|
||||
[ 2drop ]
|
||||
[ over first find-mode htmlize-lines ] if
|
||||
</pre>
|
||||
</body>
|
||||
</html> ;
|
||||
|
||||
: htmlize-file ( path -- )
|
||||
dup <file-reader> lines dup empty? [ 2drop ] [
|
||||
swap dup ".html" append <file-writer> [
|
||||
[
|
||||
<html>
|
||||
<head>
|
||||
<title> dup write </title>
|
||||
default-stylesheet
|
||||
</head>
|
||||
<body>
|
||||
over first
|
||||
find-mode
|
||||
load-mode
|
||||
htmlize-lines
|
||||
</body>
|
||||
</html>
|
||||
] with-html-stream
|
||||
] with-stream
|
||||
] if ;
|
||||
dup <file-reader> over ".html" append <file-writer>
|
||||
[ htmlize-stream ] with-stream ;
|
||||
|
|
|
|||
|
|
@ -32,10 +32,13 @@ IN: xmode.loader
|
|||
swap [ at string>boolean ] curry map first3 ;
|
||||
|
||||
: parse-literal-matcher ( tag -- matcher )
|
||||
dup children>string swap position-attrs <matcher> ;
|
||||
dup children>string
|
||||
\ ignore-case? get [ <ignore-case> ] when
|
||||
swap position-attrs <matcher> ;
|
||||
|
||||
: parse-regexp-matcher ( tag -- matcher )
|
||||
dup children>string <regexp> swap position-attrs <matcher> ;
|
||||
dup children>string <regexp>
|
||||
swap position-attrs <matcher> ;
|
||||
|
||||
! SPAN's children
|
||||
<TAGS: parse-begin/end-tag
|
||||
|
|
@ -130,22 +133,25 @@ RULE: MARK_FOLLOWING mark-following-rule
|
|||
RULE: MARK_PREVIOUS mark-previous-rule
|
||||
shared-tag-attrs match-type-attr literal-start ;
|
||||
|
||||
: parse-keyword-tag
|
||||
dup name-tag string>token swap children>string rot set-at ;
|
||||
: parse-keyword-tag ( tag keyword-map -- )
|
||||
>r dup name-tag string>token swap children>string r> set-at ;
|
||||
|
||||
TAG: KEYWORDS ( rule-set tag -- key value )
|
||||
>r rule-set-keywords r>
|
||||
child-tags [ parse-keyword-tag ] curry* each ;
|
||||
\ ignore-case? get <keyword-map>
|
||||
swap child-tags [ over parse-keyword-tag ] each
|
||||
swap set-rule-set-keywords ;
|
||||
|
||||
TAGS>
|
||||
|
||||
: ?<regexp> dup [ <regexp> ] when ;
|
||||
|
||||
: (parse-rules-tag) ( tag -- rule-set )
|
||||
<rule-set>
|
||||
{
|
||||
{ "SET" string>rule-set-name set-rule-set-name }
|
||||
{ "IGNORE_CASE" string>boolean set-rule-set-ignore-case? }
|
||||
{ "HIGHLIGHT_DIGITS" string>boolean set-rule-set-highlight-digits? }
|
||||
{ "DIGIT_RE" <regexp> set-rule-set-digit-re } ! XXX
|
||||
{ "DIGIT_RE" ?<regexp> set-rule-set-digit-re }
|
||||
{ "ESCAPE" f add-escape-rule }
|
||||
{ "DEFAULT" string>token set-rule-set-default }
|
||||
{ "NO_WORD_SEP" f set-rule-set-no-word-sep }
|
||||
|
|
@ -153,9 +159,10 @@ TAGS>
|
|||
|
||||
: parse-rules-tag ( tag -- rule-set )
|
||||
dup (parse-rules-tag) [
|
||||
swap child-tags [
|
||||
parse-rule-tag
|
||||
] curry* each
|
||||
[
|
||||
dup rule-set-ignore-case? \ ignore-case? set
|
||||
swap child-tags [ parse-rule-tag ] curry* each
|
||||
] with-scope
|
||||
] keep ;
|
||||
|
||||
: merge-rule-set-props ( props rule-set -- )
|
||||
|
|
|
|||
|
|
@ -109,3 +109,21 @@ IN: temporary
|
|||
] [
|
||||
f "$FOO" "shellscript" load-mode tokenize-line nip
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ token f "AND" KEYWORD1 }
|
||||
}
|
||||
] [
|
||||
f "AND" "pascal" load-mode tokenize-line nip
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ token f "Comment {" COMMENT1 }
|
||||
T{ token f "XXX" COMMENT1 }
|
||||
T{ token f "}" COMMENT1 }
|
||||
}
|
||||
] [
|
||||
f "Comment {XXX}" "rebol" load-mode tokenize-line nip
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -15,8 +15,8 @@ assocs combinators combinators.lib strings regexp splitting ;
|
|||
[ dup [ digit? ] contains? ]
|
||||
[
|
||||
dup [ digit? ] all? [
|
||||
current-rule-set rule-set-digit-re dup
|
||||
[ dupd 2drop f ] [ drop f ] if
|
||||
current-rule-set rule-set-digit-re
|
||||
dup [ dupd matches? ] [ drop f ] if
|
||||
] unless*
|
||||
]
|
||||
} && nip ;
|
||||
|
|
@ -26,7 +26,7 @@ assocs combinators combinators.lib strings regexp splitting ;
|
|||
|
||||
: resolve-delegate ( name -- rules )
|
||||
dup string? [
|
||||
"::" split1 [ swap load-mode at ] [ rule-sets get at ] if*
|
||||
"::" split1 [ swap load-mode ] [ rule-sets get ] if* at
|
||||
] when ;
|
||||
|
||||
: rule-set-keyword-maps ( ruleset -- seq )
|
||||
|
|
@ -45,13 +45,6 @@ assocs combinators combinators.lib strings regexp splitting ;
|
|||
dup mark-number [ ] [ mark-keyword ] ?if
|
||||
[ prev-token, ] when* ;
|
||||
|
||||
: check-terminate-char ( -- )
|
||||
current-rule-set rule-set-terminate-char [
|
||||
position get <= [
|
||||
terminated? on
|
||||
] when
|
||||
] when* ;
|
||||
|
||||
: current-char ( -- char )
|
||||
position get line get nth ;
|
||||
|
||||
|
|
@ -74,11 +67,22 @@ GENERIC: text-matches? ( position text -- match-count/f )
|
|||
M: f text-matches? 2drop f ;
|
||||
|
||||
M: string text-matches?
|
||||
! XXX ignore case
|
||||
>r line get swap tail-slice r>
|
||||
[ head? ] keep length and ;
|
||||
|
||||
! M: regexp text-matches? ... ;
|
||||
M: ignore-case text-matches?
|
||||
>r line get swap tail-slice r>
|
||||
ignore-case-string
|
||||
2dup shorter? [
|
||||
2drop f
|
||||
] [
|
||||
[ length head-slice ] keep
|
||||
[ [ >upper ] 2apply sequence= ] keep
|
||||
length and
|
||||
] if ;
|
||||
|
||||
M: regexp text-matches?
|
||||
2drop f ; ! >r line get swap tail-slice r> match-head ;
|
||||
|
||||
: rule-start-matches? ( rule -- match-count/f )
|
||||
dup rule-start tuck swap can-match-here? [
|
||||
|
|
@ -284,8 +288,6 @@ M: mark-previous-rule handle-rule-start
|
|||
|
||||
: mark-token-loop ( -- )
|
||||
position get line get length < [
|
||||
check-terminate-char
|
||||
|
||||
{
|
||||
[ check-end-delegate ]
|
||||
[ check-every-rule ]
|
||||
|
|
@ -302,8 +304,7 @@ M: mark-previous-rule handle-rule-start
|
|||
|
||||
: unwind-no-line-break ( -- )
|
||||
context get line-context-parent [
|
||||
line-context-in-rule rule-no-line-break?
|
||||
terminated? get or [
|
||||
line-context-in-rule rule-no-line-break? [
|
||||
pop-context
|
||||
unwind-no-line-break
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -16,7 +16,6 @@ SYMBOL: seen-whitespace-end?
|
|||
SYMBOL: escaped?
|
||||
SYMBOL: process-escape?
|
||||
SYMBOL: delegate-end-escaped?
|
||||
SYMBOL: terminated?
|
||||
|
||||
: current-rule ( -- rule )
|
||||
context get line-context-in-rule ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,11 @@
|
|||
USING: xmode.tokens xmode.keyword-map kernel
|
||||
sequences vectors assocs strings memoize ;
|
||||
sequences vectors assocs strings memoize regexp ;
|
||||
IN: xmode.rules
|
||||
|
||||
TUPLE: ignore-case string ;
|
||||
|
||||
C: <ignore-case> ignore-case
|
||||
|
||||
! Based on org.gjt.sp.jedit.syntax.ParserRuleSet
|
||||
TUPLE: rule-set
|
||||
name
|
||||
|
|
@ -20,12 +24,11 @@ no-word-sep
|
|||
|
||||
: init-rule-set ( ruleset -- )
|
||||
#! Call after constructor.
|
||||
>r H{ } clone H{ } clone V{ } clone f <keyword-map> r>
|
||||
>r H{ } clone H{ } clone V{ } clone r>
|
||||
{
|
||||
set-rule-set-rules
|
||||
set-rule-set-props
|
||||
set-rule-set-imports
|
||||
set-rule-set-keywords
|
||||
} set-slots ;
|
||||
|
||||
: <rule-set> ( -- ruleset )
|
||||
|
|
@ -46,8 +49,9 @@ MEMO: standard-rule-set ( id -- ruleset )
|
|||
] when* ;
|
||||
|
||||
: rule-set-no-word-sep* ( ruleset -- str )
|
||||
dup rule-set-keywords keyword-map-no-word-sep*
|
||||
swap rule-set-no-word-sep "_" 3append ;
|
||||
dup rule-set-no-word-sep
|
||||
swap rule-set-keywords dup [ keyword-map-no-word-sep* ] when
|
||||
"_" 3append ;
|
||||
|
||||
! Match restrictions
|
||||
TUPLE: matcher text at-line-start? at-whitespace-end? at-word-start? ;
|
||||
|
|
@ -97,10 +101,20 @@ TUPLE: escape-rule ;
|
|||
escape-rule construct-rule
|
||||
[ set-rule-start ] keep ;
|
||||
|
||||
GENERIC: text-hash-char ( text -- ch )
|
||||
|
||||
M: f text-hash-char ;
|
||||
|
||||
M: string text-hash-char first ;
|
||||
|
||||
M: ignore-case text-hash-char ignore-case-string first ;
|
||||
|
||||
M: regexp text-hash-char drop f ;
|
||||
|
||||
: rule-chars* ( rule -- string )
|
||||
dup rule-chars
|
||||
swap rule-start matcher-text
|
||||
dup string? [ first add ] [ drop ] if ;
|
||||
text-hash-char [ add ] when* ;
|
||||
|
||||
: add-rule ( rule ruleset -- )
|
||||
>r dup rule-chars* >upper swap
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: http.server help.markup help.syntax kernel prettyprint
|
|||
sequences parser namespaces words classes math tuples.private
|
||||
quotations arrays strings ;
|
||||
|
||||
IN: furnace
|
||||
IN: furnace.scaffold
|
||||
|
||||
TUPLE: furnace-model model ;
|
||||
C: <furnace-model> furnace-model
|
||||
|
|
@ -40,6 +40,11 @@ HELP: crud-lookup*
|
|||
{ $values { "string" string } { "class" class } { "tuple" tuple } }
|
||||
"A CRUD utility function - same as crud-lookup, but always returns a tuple of the given class. When the lookup fails, returns a tuple of the given class with all slots set to f." ;
|
||||
|
||||
: render-page ( model template title -- )
|
||||
[
|
||||
[ render-component ] simple-html-document
|
||||
] serve-html ;
|
||||
|
||||
: crud-page ( model template title -- )
|
||||
[ "libs/furnace/crud-templates" template-path set render-page ]
|
||||
with-scope ;
|
||||
Loading…
Reference in New Issue