#! by returning a quotation that will pass the original
#! quotation to the callback continuation.
[ , callback-cc get , \ continue-with , ] [ ] make ;
-
+
+: quot-url ( quot -- url )
+ callback-quot expirable register-continuation id>url ;
+
: quot-href ( text quot -- )
#! Write to standard output an HTML HREF where the href,
#! when referenced, will call the quotation and then return
#! back to the most recent 'show' call (via the callback-cc).
#! The text of the link will be the 'text' argument on the
#! stack.
- <a callback-quot expirable register-continuation id>url =href a> write </a> ;
+ <a quot-url =href a> write </a> ;
: init-session-namespace ( -- )
#! Setup the initial session namespace. Currently this only
: button ( label -- )
#! Output an HTML submit button with the given label.
<input "submit" =type =value input/> ;
-
-: with-simple-html-output ( quot -- )
- #! Run the quotation inside an HTML stream wrapped
- #! around stdio.
- <pre>
- stdio get <html-stream> [
- call
- ] with-stream
- </pre> ;
-
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: html
-USING: generic hashtables help http io kernel lists math
-namespaces sequences strings styles words xml ;
+USING: generic hashtables help http inspector io
+kernel lists math namespaces sequences strings styles words xml ;
: hex-color, ( triplet -- )
3 swap head
<span =style span> call </span>
] if ;
+: border-css, ( border -- )
+ "border: 1px solid #" % hex-color, "; " % ;
+
+: padding-css, ( padding -- ) "padding: " % # "px; " % ;
+
+: pre-css, ( -- ) "white-space: pre; " % ;
+
: div-css-style ( style -- str )
[
H{
- { page-color [ bg-css, ] }
- ! { border-color [ font-css, ] }
+ { page-color [ bg-css, ] }
+ { border-color [ border-css, ] }
+ { border-width [ padding-css, ] }
+ { wrap-margin [ [ pre-css, ] unless ] }
} hash-apply
] "" make ;
: div-tag ( style quot -- )
- over div-css-style dup empty? [
+ swap div-css-style dup empty? [
drop call
] [
<div =style div> call </div>
GENERIC: browser-link-href ( presented -- href )
+M: object browser-link-href drop f ;
+
M: word browser-link-href
- dup word-name swap word-vocabulary [
- "/responder/browser/?vocab=" %
- url-encode %
- "&word=" %
- url-encode %
- ] "" make ;
+ "/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? [
[ "/responder/help/" % url-encode % ] "" make
] if ;
-M: object browser-link-href
- drop f ;
-
-: browser-link-tag ( style quot -- style )
+: object-link-tag ( style quot -- )
presented pick hash browser-link-href
[ <a =href a> call </a> ] [ call ] if* ;
do-escaping stdio get delegate-write
] span-tag
] file-link-tag
- ] browser-link-tag
+ ] object-link-tag
] with-stream* ;
-: pre-tag ( style quot -- )
- wrap-margin rot hash [
- call
- ] [
- <pre> call </pre>
- ] if ;
-
M: html-stream with-nested-stream ( quot style stream -- )
[
[
[
stdio get <nested-stream> swap with-stream*
- ] pre-tag
- ] div-tag
+ ] div-tag
+ ] object-link-tag
] with-stream* ;
M: html-stream stream-terpri [ <br/> ] with-stream* ;
: default-css ( -- )
<style>
- "A:link { text-decoration:none}" print
- "A:visited { text-decoration:none}" print
- "A:active { text-decoration:none}" print
- "A:hover, A.nav:hover { border: 1px solid black; text-decoration: none; margin: -1px }" 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: none; color: black; }" print
</style> ;
: html-document ( title quot -- )
--- /dev/null
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: inspect-responder
+USING: cont-responder generic hashtables help html inspector
+kernel lists namespaces sequences ;
+
+! Mini object inspector
+: http-inspect ( obj -- )
+ "Inspecting " over summary append
+ [ describe ] simple-html-document ;
+
+M: general-t browser-link-href
+ "/responder/inspector/" swap
+ [ [ http-inspect ] show-final ] curry quot-url
+ append ;
+
+: inspect-responder ( url -- ) drop global http-inspect ;