From 7c0ae6a136cffc2ee99503c0e062a3f2088a91c7 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Sun, 1 Aug 2004 22:28:17 +0000
Subject: [PATCH] added first cut of browser code

---
 contrib/cont-responder/browser.factor | 142 ++++++++++++++++++++++++++
 contrib/cont-responder/load.factor    |   1 +
 2 files changed, 143 insertions(+)
 create mode 100644 contrib/cont-responder/browser.factor

diff --git a/contrib/cont-responder/browser.factor b/contrib/cont-responder/browser.factor
new file mode 100644
index 0000000000..a0994a62b9
--- /dev/null
+++ b/contrib/cont-responder/browser.factor
@@ -0,0 +1,142 @@
+! Copyright (C) 2004 Chris Double.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! An Smalltalk-link browser that runs in the httpd server using
+! cont-responder facilities.
+!
+IN: browser
+USE: cont-html
+USE: cont-responder
+USE: cont-utils
+USE: stack
+USE: stdio
+USE: combinators
+USE: namespaces
+USE: vocabularies
+USE: lists
+USE: streams
+USE: strings
+USE: inspector
+USE: kernel
+USE: prettyprint
+USE: words
+USE: html
+USE: parser
+
+: <browser> ( vocab word -- )
+  #! An object for storing the current browser
+  #! user interface state.
+  <namespace> [
+    "current-word" set
+    "current-vocab" set
+  ] extend ;
+
+: write-vocab-list ( -- )
+  #! Write out the HTML for the list of vocabularies
+  <select name= "vocabs" size= "20" onchange= "document.forms.main.submit()" select> [
+    vocabs [ 
+      dup "current-vocab" get [ "" ] unless* = [
+      "<option selected>" write
+     ] [
+        "<option>" write
+     ] ifte 
+     chars>entities write 
+     "</option>\n" write     
+    ] each
+  ] </select> ;
+
+: write-word-list ( vocab -- )
+  #! Write out the HTML for the list of words in a vocabulary.
+  <select name= "words" size= "20" onchange= "document.forms.main.submit()" select> [
+    words [ 
+      dup "current-word" get [ "" ] unless* str-compare 0 = [
+      "<option selected>" write
+     ] [
+        "<option>" write
+     ] ifte 
+     chars>entities write 
+     "</option>\n" write     
+    ] each
+  ] </select> ;
+
+: write-editable-word-source ( vocab word -- )
+  #! Write the source in a manner allowing it to be edited.
+  <textarea name= "eval" rows= "30" cols= "80" textarea> [
+    1024 <string-output-stream> dup >r [
+      >r words r> swap [ over swap dup word-name rot = [ see ] [ drop ] ifte ] each drop    
+    ] with-stream r> stream>str chars>entities write
+  ] </textarea> <br/>
+  "Accept" button ;
+
+: write-word-source ( vocab word -- )
+  #! Write the source for the given word from the vocab as HTML.
+  <namespace> [
+    "responder" "inspect" put
+    "Edit" [ "edit-state" t put ] quot-href <br/>
+    "edit-state" get [
+      write-editable-word-source 
+    ] [
+      [ 
+        >r words r> swap [ over swap dup word-name rot = [ see ] [ drop ] ifte ] each drop
+      ] with-simple-html-output
+    ] ifte
+  ] bind drop ;
+
+: write-browser-body ( -- )
+  #! Write out the HTML for the body of the main browser page.
+  [
+    [ write-vocab-list ] 
+    [ "current-vocab" get write-word-list ] 
+    [ 
+      "current-vocab" get "current-word" get write-word-source
+    ]
+  ] horizontal-layout ;
+USE: logging
+: browse ( <browser> -- )
+  #! Display a Smalltalk like browser for exploring/modifying words.
+  [
+    [
+      [
+        <html> [
+          <head> [
+            <title> [ "Factor Browser" write ] </title>
+          ] </head>
+          <body> [
+            <form name= "main" action= method= "post" form> [
+              write-browser-body 
+            ] </form>
+          ] </body>
+        ] </html> 
+      ] show 
+    ] bind [
+      "vocabs" get
+      "words" get
+      "eval" get [ log ] when 
+    ] bind <browser>
+  ] forever ;
+
+: browser-responder ( -- )
+  #! Start the Smalltalk-like browser.
+  "browser" "" <browser> browse ;
+
+"browser" [ browser-responder ] install-cont-responder
diff --git a/contrib/cont-responder/load.factor b/contrib/cont-responder/load.factor
index b585e1a4ab..ce26beb9ce 100644
--- a/contrib/cont-responder/load.factor
+++ b/contrib/cont-responder/load.factor
@@ -46,6 +46,7 @@ USE: parser
 : l5 "live-updater.factor" run-file ;
 : l6 "eval-responder.factor" run-file ;
 : l7 "live-updater-responder.factor" run-file ;
+: l8 "browser.factor" run-file ;
 : la ;
 : la [ 8888 httpd ] [ dup . flush [ la ] when* ] catch ;
 : lb [ la "httpd thread exited.\n" write flush ] in-thread  ;