initial

.gitignore

@@ -0,0 +1 @@
+argos

README.md

@@ -0,0 +1,68 @@
+# argos
+
+*Very early WIP.*
+
+[Arc](http://www.arclanguage.org) in Go.
+
+## TODOS
+
+- Destructuring assignment
+- Defining functions
+- Anonymous functions
+- Datastructures as functions
+- Characters
+- `let`
+- `with`
+- `pr`
+- `prn`
+- `if`
+- `do`
+- `when`
+- `and`
+- `no`
+- `is`
+- `in`
+- `case`
+- `for`
+- `each`
+- `while`
+- `repeat`
+- `[...]`
+- `:`
+- `~`
+- `keep`
+- `rem`
+- `all`
+- `some`
+- `pos`
+- `trues`
+- `table`
+- `listtab`
+- `obj`
+- `keys`
+- `vals`
+- `maptable`
+- `alref`
+- `string`
+- `tostring`
+- `type`
+- `coerce`
+- `pop`
+- `push`
+- `++`
+- `--`
+- `zap`
+- `sort`
+- `insort`
+- `compare`
+- `o`
+- `.`
+- `apply`
+- `len`
+- `mac`
+- `\``
+- `defop`
+- `asv`
+- `w/link`
+- `aform`
+- ...

ast/ast.go

@@ -0,0 +1,44 @@
+package ast
+
+import (
+  "fmt"
+  "strings"
+)
+
+type AST struct {
+  Tag Tag
+  Val interface{}
+}
+
+type Tag int8
+
+const (
+  Symbol Tag = iota
+  List
+  String
+  Num
+  Bool
+)
+
+func (tag Tag) String() string {
+    names := []string{
+        "Symbol",
+        "List",
+        "String",
+        "Num",
+        "Bool",
+    }
+
+    return names[tag]
+}
+
+func (ast AST) Pretty() string {
+  if ast.Tag == List {
+    var agg []string
+    for _, elem := range(ast.Val.([]AST)) {
+      agg = append(agg, elem.Pretty())
+    }
+    return "(" + strings.Join(agg, " ") + ")"
+  }
+  return fmt.Sprintf("%v", ast.Val)
+}

eval/eval.go

@@ -0,0 +1,308 @@
+package eval
+
+// TODO: a lot of code duplication that can be solved by a primitive registry
+// TODO: a lot of code duplication that can be solved by a type checking helper
+
+import (
+  "fmt"
+
+  "github.com/hellerve/argos/ast"
+)
+
+var trueVal = ast.AST{ast.Bool, true}
+var falseVal = ast.AST{ast.Bool, false}
+var nilVal = ast.AST{ast.List, []ast.AST{}}
+
+type env struct {
+  parent *env
+  values map[string]*ast.AST
+}
+
+func newEnv(parent *env) env {
+  return env{parent, make(map[string]*ast.AST)}
+}
+
+func ParentEnv() env {
+  return newEnv(nil)
+}
+
+func (e env) Lookup(elem string) (*ast.AST, error) {
+  res, ok := e.values[elem]
+
+  if !ok {
+    if e.parent == nil {
+      return nil, fmt.Errorf("Symbol not found: %s", elem)
+    }
+
+    return e.parent.Lookup(elem)
+  }
+
+  return res, nil
+}
+
+func checkArity(input []ast.AST, arity int, name string) error {
+  ilen := len(input)
+  if ilen != arity+1 {
+    return fmt.Errorf("Argument count to '%s' must be %d, was %d", name, arity, ilen)
+  }
+
+  return nil
+}
+
+func evalDef(input []ast.AST, e env) (*ast.AST, error) {
+  err := checkArity(input, 2, "=")
+
+  if err != nil {
+    return nil, err
+  }
+
+  variable := &input[1]
+
+  if variable.Tag != ast.Symbol {
+    variable, err = Eval(variable, e)
+
+    if variable.Tag != ast.Symbol {
+      return nil, fmt.Errorf("First argument to 'def' must be symbol, was %v", variable.Tag)
+    }
+  }
+
+  if err != nil {
+    return nil, err
+  }
+
+  sym := variable.Val.(string)
+
+  evald, err := Eval(&input[2], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  e.values[sym] = evald
+
+  return evald, nil
+}
+
+func arithCast(input ast.AST, e env) (float64, error) {
+  evald, err := Eval(&input, e)
+  if err != nil {
+    return 0, err
+  }
+
+  if evald.Tag != ast.Num {
+    return 0, fmt.Errorf("Cannot perform arithmetic on ", evald.Pretty())
+  }
+
+  return evald.Val.(float64), nil
+}
+
+func evalArith(input []ast.AST, e env, fn (func(float64, float64) float64)) (*ast.AST, error) {
+  ilen := len(input)
+  if ilen < 3 {
+    return nil, fmt.Errorf("Arithmetic functions take at least 2 arguments, got %d", ilen)
+  }
+
+  acc, err := arithCast(input[1], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  for _, elem := range input[2:] {
+    val, err := arithCast(elem, e)
+
+    if err != nil {
+      return nil, err
+    }
+    acc = fn(acc, val)
+  }
+
+  res := ast.AST{ast.Num, acc}
+  return &res, nil
+}
+
+func evalEq(input []ast.AST, e env) (*ast.AST, error) {
+  err := checkArity(input, 2, "iso")
+
+  if err != nil {
+    return nil, err
+  }
+
+  x, err := Eval(&input[1], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  y, err := Eval(&input[2], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  if x.Tag != y.Tag {
+    return &falseVal, nil
+  }
+
+  if x.Val == y.Val {
+    return &trueVal, nil
+  }
+  return &falseVal, nil
+}
+
+func evalCons(input []ast.AST, e env) (*ast.AST, error) {
+  err := checkArity(input, 2, "cons")
+
+  if err != nil {
+    return nil, err
+  }
+
+  lst, err := Eval(&input[2], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  if lst.Tag != ast.List {
+    return nil, fmt.Errorf("Cannot cons to non-list %s", lst.Pretty())
+  }
+
+  fst, err := Eval(&input[1], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  res := ast.AST{ast.List, append([]ast.AST{*fst}, lst.Val.([]ast.AST)...)}
+
+  return &res, nil
+}
+
+func evalCar(input []ast.AST, e env) (*ast.AST, error) {
+  err := checkArity(input, 1, "car")
+
+  if err != nil {
+    return nil, err
+  }
+
+  lst, err := Eval(&input[1], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  if lst.Tag != ast.List {
+    return nil, fmt.Errorf("Cannot car from non-list %s", lst.Pretty())
+  }
+
+  res := lst.Val.([]ast.AST)[0]
+  return &res, nil
+}
+
+func evalCdr(input []ast.AST, e env) (*ast.AST, error) {
+  err := checkArity(input, 1, "cdr")
+
+  if err != nil {
+    return nil, err
+  }
+
+  lst, err := Eval(&input[1], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  if lst.Tag != ast.List {
+    return nil, fmt.Errorf("Cannot cdr from non-list %s", lst.Pretty())
+  }
+
+  res := ast.AST{ast.List, lst.Val.([]ast.AST)[1:]}
+  return &res, nil
+}
+
+func evalNull(input []ast.AST, e env) (*ast.AST, error) {
+  err := checkArity(input, 1, "null")
+
+  if err != nil {
+    return nil, err
+  }
+
+  lst, err := Eval(&input[1], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  if lst.Tag != ast.List {
+    return nil, fmt.Errorf("Cannot call null? on non-list %s", lst.Pretty())
+  }
+
+  res := ast.AST{ast.Bool, len(lst.Val.([]ast.AST)) == 0}
+  return &res, nil
+}
+
+func evalList(input *ast.AST, e env) (*ast.AST, error) {
+  l := input.Val.([]ast.AST)
+  head := l[0]
+
+  if head.Tag != ast.Symbol {
+    err := fmt.Errorf("Calling non-symbol: %s", head.Pretty())
+
+    return nil, err
+  }
+
+  sym := head.Val.(string)
+
+  switch sym {
+    case "=":
+      return evalDef(l, e)
+    case "iso":
+      return evalEq(l, e)
+    case "quote":
+      res := l[1]
+      return &res, nil
+    case "cons":
+      return evalCons(l, e)
+    case "car":
+      return evalCar(l, e)
+    case "cdr":
+      return evalCdr(l, e)
+    case "null?":
+      return evalNull(l, e)
+    case "+":
+      return evalArith(l, e, func(x float64, y float64) float64 { return x + y })
+    case "-":
+      return evalArith(l, e, func(x float64, y float64) float64 { return x - y })
+    case "*":
+      return evalArith(l, e, func(x float64, y float64) float64 { return x * y })
+    case "/":
+      return evalArith(l, e, func(x float64, y float64) float64 { return x / y })
+    case "%":
+      return evalArith(l, e, func(x float64, y float64) float64 { return float64(int64(x) % int64(y)) })
+  }
+  return input, nil
+}
+
+func Eval(input *ast.AST, e env) (*ast.AST, error) {
+  if (input.Tag == ast.List) {
+    return evalList(input, e)
+  }
+  if (input.Tag == ast.Symbol) {
+    val := input.Val.(string)
+
+    var err error
+    var res *ast.AST
+    switch val {
+      case "true":
+        res = &trueVal
+      case "false":
+        res = &falseVal
+      case "nil":
+        res = &nilVal
+      default:
+        res, err = e.Lookup(val)
+    }
+    return res, err
+  }
+  return input, nil
+}

lib/README.md

@@ -0,0 +1,5 @@
+# lib
+
+The Arc files from Arc3.1, obtainable [here](http://www.arclanguage.org/arc3.1.tar),
+copied verbatim. See [copyright](./copyright) for the original copyright. I do
+not own any of this, nor have I written any of it.

lib/app.arc

@@ -0,0 +1,671 @@
+; Application Server.  Layer inserted 2 Sep 06.
+
+; ideas: 
+; def a general notion of apps of which prompt is one, news another
+; give each user a place to store data?  A home dir?
+
+; A user is simply a string: "pg". Use /whoami to test user cookie.
+
+(= hpwfile*   "arc/hpw"
+   oidfile*   "arc/openids"
+   adminfile* "arc/admins"
+   cookfile*  "arc/cooks")
+
+(def asv ((o port 8080))
+  (load-userinfo)
+  (serve port))
+
+(def load-userinfo ()
+  (= hpasswords*   (safe-load-table hpwfile*)
+     openids*      (safe-load-table oidfile*)
+     admins*       (map string (errsafe (readfile adminfile*)))
+     cookie->user* (safe-load-table cookfile*))
+  (maptable (fn (k v) (= (user->cookie* v) k))
+            cookie->user*))
+
+; idea: a bidirectional table, so don't need two vars (and sets)
+
+(= cookie->user* (table) user->cookie* (table) logins* (table))
+
+(def get-user (req) 
+  (let u (aand (alref req!cooks "user") (cookie->user* (sym it)))
+    (when u (= (logins* u) req!ip))
+    u))
+
+(mac when-umatch (user req . body)
+  `(if (is ,user (get-user ,req))
+       (do ,@body)
+       (mismatch-message)))
+
+(def mismatch-message () 
+  (prn "Dead link: users don't match."))
+
+(mac when-umatch/r (user req . body)
+  `(if (is ,user (get-user ,req))
+       (do ,@body)
+       "mismatch"))
+
+(defop mismatch req (mismatch-message))
+
+(mac uform (user req after . body)
+  `(aform (fn (,req)
+            (when-umatch ,user ,req
+              ,after))
+     ,@body))
+
+(mac urform (user req after . body)
+  `(arform (fn (,req)
+             (when-umatch/r ,user ,req 
+               ,after))
+     ,@body))
+
+; Like onlink, but checks that user submitting the request is the
+; same it was generated for.  For extra protection could log the 
+; username and ip addr of every genlink, and check if they match.
+
+(mac ulink (user text . body)  
+  (w/uniq req
+    `(linkf ,text (,req) 
+       (when-umatch ,user ,req ,@body))))
+
+
+(defop admin req (admin-gate (get-user req)))
+
+(def admin-gate (u)
+  (if (admin u)
+      (admin-page u)
+      (login-page 'login nil
+                  (fn (u ip)  (admin-gate u)))))
+
+(def admin (u) (and u (mem u admins*)))
+
+(def user-exists (u) (and u (hpasswords* u) u))
+
+(def admin-page (user . msg)
+  (whitepage 
+    (prbold "Admin: ")
+    (hspace 20)
+    (pr user " | ")
+    (w/link (do (logout-user user)
+                (whitepage (pr "Bye " user ".")))
+      (pr "logout"))
+    (when msg (hspace 10) (map pr msg))
+    (br2)
+    (aform (fn (req)
+             (when-umatch user req
+               (with (u (arg req "u") p (arg req "p"))
+                 (if (or (no u) (no p) (is u "") (is p ""))
+                      (pr "Bad data.")
+                     (user-exists u)
+                      (admin-page user "User already exists: " u)
+                      (do (create-acct u p)
+                          (admin-page user))))))
+      (pwfields "create (server) account"))))
+
+(def cook-user (user)
+  (let id (new-user-cookie)
+    (= (cookie->user*   id) user
+       (user->cookie* user)   id)
+    (save-table cookie->user* cookfile*)
+    id))
+
+; Unique-ids are only unique per server invocation.
+
+(def new-user-cookie ()
+  (let id (unique-id)
+    (if (cookie->user* id) (new-user-cookie) id)))
+
+(def logout-user (user)
+  (wipe (logins* user))
+  (wipe (cookie->user* (user->cookie* user)) (user->cookie* user))
+  (save-table cookie->user* cookfile*))
+
+(def create-acct (user pw)
+  (set (dc-usernames* (downcase user)))
+  (set-pw user pw))
+
+(def disable-acct (user)
+  (set-pw user (rand-string 20))
+  (logout-user user))
+  
+(def set-pw (user pw)
+  (= (hpasswords* user) (and pw (shash pw)))
+  (save-table hpasswords* hpwfile*))
+
+(def hello-page (user ip)
+  (whitepage (prs "hello" user "at" ip)))
+
+(defop login req (login-page 'login))
+
+; switch is one of: register, login, both
+
+; afterward is either a function on the newly created username and
+; ip address, in which case it is called to generate the next page 
+; after a successful login, or a pair of (function url), which means 
+; call the function, then redirect to the url.
+
+; classic example of something that should just "return" a val
+; via a continuation rather than going to a new page.
+
+(def login-page (switch (o msg nil) (o afterward hello-page))
+  (whitepage
+    (pagemessage msg)
+    (when (in switch 'login 'both)
+      (login-form "Login" switch login-handler afterward)
+      (hook 'login-form afterward)
+      (br2))
+    (when (in switch 'register 'both)
+      (login-form "Create Account" switch create-handler afterward))))
+
+(def login-form (label switch handler afterward)
+  (prbold label)
+  (br2)
+  (fnform (fn (req) (handler req switch afterward))
+          (fn () (pwfields (downcase label)))
+          (acons afterward)))
+
+(def login-handler (req switch afterward)
+  (logout-user (get-user req))
+  (aif (good-login (arg req "u") (arg req "p") req!ip)
+       (login it req!ip (user->cookie* it) afterward)
+       (failed-login switch "Bad login." afterward)))
+
+(def create-handler (req switch afterward)
+  (logout-user (get-user req))
+  (with (user (arg req "u") pw (arg req "p"))
+    (aif (bad-newacct user pw)
+         (failed-login switch it afterward)
+         (do (create-acct user pw)
+             (login user req!ip (cook-user user) afterward)))))
+
+(def login (user ip cookie afterward)
+  (= (logins* user) ip)
+  (prcookie cookie)
+  (if (acons afterward)
+      (let (f url) afterward
+        (f user ip)
+        url)
+      (do (prn)
+          (afterward user ip))))
+
+(def failed-login (switch msg afterward)
+  (if (acons afterward)
+      (flink (fn ignore (login-page switch msg afterward)))
+      (do (prn)
+          (login-page switch msg afterward))))
+
+(def prcookie (cook)
+  (prn "Set-Cookie: user=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT"))
+
+(def pwfields ((o label "login"))
+  (inputs u username 20 nil
+          p password 20 nil)
+  (br)
+  (submit label))
+
+(= good-logins* (queue) bad-logins* (queue))
+
+(def good-login (user pw ip)
+  (let record (list (seconds) ip user)
+    (if (and user pw (aand (shash pw) (is it (hpasswords* user))))
+        (do (unless (user->cookie* user) (cook-user user))
+            (enq-limit record good-logins*)
+            user)
+        (do (enq-limit record bad-logins*)
+            nil))))
+
+; Create a file in case people have quote chars in their pws.  I can't 
+; believe there's no way to just send the chars.
+
+(def shash (str)
+  (let fname (+ "/tmp/shash" (rand-string 10))
+    (w/outfile f fname (disp str f))
+    (let res (tostring (system (+ "openssl dgst -sha1 <" fname)))
+      (do1 (cut res 0 (- (len res) 1))
+           (rmfile fname)))))
+
+(= dc-usernames* (table))
+
+(def username-taken (user)
+  (when (empty dc-usernames*)
+    (each (k v) hpasswords*
+      (set (dc-usernames* (downcase k)))))
+  (dc-usernames* (downcase user)))
+
+(def bad-newacct (user pw)
+  (if (no (goodname user 2 15))
+       "Usernames can only contain letters, digits, dashes and 
+        underscores, and should be between 2 and 15 characters long.  
+        Please choose another."
+      (username-taken user)
+       "That username is taken. Please choose another."
+      (or (no pw) (< (len pw) 4))
+       "Passwords should be a least 4 characters long.  Please 
+        choose another."
+       nil))
+
+(def goodname (str (o min 1) (o max nil))
+  (and (isa str 'string)
+       (>= (len str) min)
+       (~find (fn (c) (no (or (alphadig c) (in c #\- #\_))))
+              str)
+       (isnt (str 0) #\-)
+       (or (no max) (<= (len str) max))
+       str))
+
+(defop logout req
+  (aif (get-user req)
+       (do (logout-user it)
+           (pr "Logged out."))
+       (pr "You were not logged in.")))
+
+(defop whoami req
+  (aif (get-user req)
+       (prs it 'at req!ip)
+       (do (pr "You are not logged in. ")
+           (w/link (login-page 'both) (pr "Log in"))
+           (pr "."))))
+
+
+(= formwid* 60 bigformwid* 80 numwid* 16 formatdoc-url* nil)
+
+; Eventually figure out a way to separate type name from format of 
+; input field, instead of having e.g. toks and bigtoks
+
+(def varfield (typ id val)
+  (if (in typ 'string 'string1 'url)
+       (gentag input type 'text name id value val size formwid*)
+      (in typ 'num 'int 'posint 'sym)
+       (gentag input type 'text name id value val size numwid*)
+      (in typ 'users 'toks)
+       (gentag input type 'text name id value (tostring (apply prs val))
+                     size formwid*)    
+      (is typ 'sexpr)
+       (gentag input type 'text name id 
+                     value (tostring (map [do (write _) (sp)] val))
+                     size formwid*)
+      (in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks)
+       (let text (if (in typ 'syms 'bigtoks)
+                      (tostring (apply prs val))
+                     (is typ 'lines)
+                      (tostring (apply pr (intersperse #\newline val)))
+                     (in typ 'mdtext 'mdtext2)
+                      (unmarkdown val)
+                     (no val)
+                      ""
+                     val)
+         (tag (textarea cols (if (is typ 'doc) bigformwid* formwid*) 
+                        rows (needrows text formwid* 4)
+                        wrap 'virtual 
+                        style (if (is typ 'doc) "font-size:8.5pt")
+                        name id)
+           (prn) ; needed or 1 initial newline gets chopped off
+           (pr text))
+         (when (and formatdoc-url* (in typ 'mdtext 'mdtext2))
+           (pr " ")
+           (tag (font size -2)
+             (link "help" formatdoc-url* (gray 175)))))
+      (caris typ 'choice)
+       (menu id (cddr typ) val)
+      (is typ 'yesno)
+       (menu id '("yes" "no") (if val "yes" "no"))
+      (is typ 'hexcol)
+       (gentag input type 'text name id value val)
+      (is typ 'time)
+       (gentag input type 'text name id value (if val (english-time val) ""))
+      (is typ 'date)
+       (gentag input type 'text name id value (if val (english-date val) ""))
+       (err "unknown varfield type" typ)))
+
+(def text-rows (text wid (o pad 3))
+  (+ (trunc (/ (len text) (* wid .8))) pad))
+
+(def needrows (text cols (o pad 0))
+  (+ pad (max (+ 1 (count #\newline text))
+              (roundup (/ (len text) (- cols 5))))))
+
+(def varline (typ id val (o liveurls))
+  (if (in typ 'users 'syms 'toks 'bigtoks)  (apply prs val)
+      (is typ 'lines)                       (map prn val)
+      (is typ 'yesno)                       (pr (if val 'yes 'no))
+      (caris typ 'choice)                   (varline (cadr typ) nil val)
+      (is typ 'url)                         (if (and liveurls (valid-url val))
+                                                (link val val)
+                                                (pr val))
+      (text-type typ)                       (pr (or val ""))
+                                            (pr val)))
+
+(def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2))
+
+; Newlines in forms come back as /r/n.  Only want the /ns. Currently
+; remove the /rs in individual cases below.  Could do it in aform or
+; even in the parsing of http requests, in the server.
+
+; Need the calls to striptags so that news users can't get html
+; into a title or comment by editing it.  If want a form that 
+; can take html, just create another typ for it.
+
+(def readvar (typ str (o fail nil))
+  (case (carif typ)
+    string  (striptags str)
+    string1 (if (blank str) fail (striptags str))
+    url     (if (blank str) "" (valid-url str) (clean-url str) fail)
+    num     (let n (saferead str) (if (number n) n fail))
+    int     (let n (saferead str)
+              (if (number n) (round n) fail))
+    posint  (let n (saferead str)
+              (if (and (number n) (> n 0)) (round n) fail))
+    text    (striptags str)
+    doc     (striptags str)
+    mdtext  (md-from-form str)
+    mdtext2 (md-from-form str t)                      ; for md with no links
+    sym     (or (sym:car:tokens str) fail)
+    syms    (map sym (tokens str))
+    sexpr   (errsafe (readall str))
+    users   (rem [no (goodname _)] (tokens str))
+    toks    (tokens str)
+    bigtoks (tokens str)
+    lines   (lines str)
+    choice  (readvar (cadr typ) str)
+    yesno   (is str "yes")
+    hexcol  (if (hex>color str) str fail)
+    time    (or (errsafe (parse-time str)) fail)
+    date    (or (errsafe (parse-date str)) fail)
+            (err "unknown readvar type" typ)))
+
+; dates should be tagged date, and just redefine <
+
+(def varcompare (typ)
+  (if (in typ 'syms 'sexpr 'users 'toks 'bigtoks 'lines 'hexcol)
+       (fn (x y) (> (len x) (len y)))
+      (is typ 'date)
+       (fn (x y)
+         (or (no y) (and x (date< x y))))
+       (fn (x y)
+         (or (empty y) (and (~empty x) (< x y))))))
+
+
+; (= fail* (uniq))
+
+(def fail* ()) ; coudn't possibly come back from a form
+  
+; Takes a list of fields of the form (type label value view modify) and 
+; a fn f and generates a form such that when submitted (f label newval) 
+; will be called for each valid value.  Finally done is called.
+
+(def vars-form (user fields f done (o button "update") (o lasts))
+  (taform lasts
+          (if (all [no (_ 4)] fields)
+              (fn (req))
+              (fn (req)
+                (when-umatch user req
+                  (each (k v) req!args
+                    (let name (sym k)
+                      (awhen (find [is (cadr _) name] fields)
+                        ; added sho to fix bug
+                        (let (typ id val sho mod) it
+                          (when (and mod v)
+                            (let newval (readvar typ v fail*)
+                              (unless (is newval fail*)
+                                (f name newval))))))))
+                  (done))))
+     (tab
+       (showvars fields))
+     (unless (all [no (_ 4)] fields)  ; no modifiable fields
+       (br)
+       (submit button))))
+                
+(def showvars (fields (o liveurls))
+  (each (typ id val view mod question) fields
+    (when view
+      (when question
+        (tr (td (prn question))))
+      (tr (unless question (tag (td valign 'top)  (pr id ":")))
+          (td (if mod 
+                  (varfield typ id val)
+                  (varline  typ id val liveurls))))
+      (prn))))
+
+; http://daringfireball.net/projects/markdown/syntax
+
+(def md-from-form (str (o nolinks))
+  (markdown (trim (rem #\return (esc-tags str)) 'end) 60 nolinks))
+
+(def markdown (s (o maxurl) (o nolinks))
+  (let ital nil
+    (tostring
+      (forlen i s
+        (iflet (newi spaces) (indented-code s i (if (is i 0) 2 0))
+               (do (pr  "<p><pre><code>")
+                 (let cb (code-block s (- newi spaces 1))
+                   (pr cb)
+                   (= i (+ (- newi spaces 1) (len cb))))
+                 (pr "</code></pre>"))
+               (iflet newi (parabreak s i (if (is i 0) 1 0))
+                      (do (unless (is i 0) (pr "<p>"))
+                          (= i (- newi 1)))
+                      (and (is (s i) #\*)
+                           (or ital 
+                               (atend i s) 
+                               (and (~whitec (s (+ i 1)))
+                                    (pos #\* s (+ i 1)))))
+                       (do (pr (if ital "</i>" "<i>"))
+                           (= ital (no ital)))
+                      (and (no nolinks)
+                           (or (litmatch "http://" s i) 
+                               (litmatch "https://" s i)))
+                       (withs (n   (urlend s i)
+                               url (clean-url (cut s i n)))
+                         (tag (a href url rel 'nofollow)
+                           (pr (if (no maxurl) url (ellipsize url maxurl))))
+                         (= i (- n 1)))
+                       (writec (s i))))))))
+
+(def indented-code (s i (o newlines 0) (o spaces 0))
+  (let c (s i)
+    (if (nonwhite c)
+         (if (and (> newlines 1) (> spaces 1))
+             (list i spaces)
+             nil)
+        (atend i s)
+         nil
+        (is c #\newline)
+         (indented-code s (+ i 1) (+ newlines 1) 0)
+         (indented-code s (+ i 1) newlines       (+ spaces 1)))))
+
+; If i is start a paragraph break, returns index of start of next para.
+
+(def parabreak (s i (o newlines 0))
+  (let c (s i)
+    (if (or (nonwhite c) (atend i s))
+        (if (> newlines 1) i nil)
+        (parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0))))))
+
+; Returns the indices of the next paragraph break in s, if any.
+
+(def next-parabreak (s i)
+  (unless (atend i s)
+    (aif (parabreak s i) 
+         (list i it)
+         (next-parabreak s (+ i 1)))))
+
+(def paras (s (o i 0))
+  (if (atend i s)
+      nil
+      (iflet (endthis startnext) (next-parabreak s i)
+             (cons (cut s i endthis)
+                   (paras s startnext))
+             (list (trim (cut s i) 'end)))))
+
+
+; Returns the index of the first char not part of the url beginning
+; at i, or len of string if url goes all the way to the end.
+
+; Note that > immediately after a url (http://foo.com>) will cause
+; an odd result, because the > gets escaped to something beginning
+; with &, which is treated as part of the url.  Perhaps the answer
+; is just to esc-tags after markdown instead of before.
+
+; Treats a delimiter as part of a url if it is (a) an open delimiter
+; not followed by whitespace or eos, or (b) a close delimiter 
+; balancing a previous open delimiter.
+
+(def urlend (s i (o indelim))
+  (let c (s i)
+    (if (atend i s)
+         (if ((orf punc whitec opendelim) c) 
+              i 
+             (closedelim c)
+              (if indelim (+ i 1) i)
+             (+ i 1))
+        (if (or (whitec c)
+                (and (punc c) (whitec (s (+ i 1))))
+                (and ((orf whitec punc) (s (+ i 1)))
+                     (or (opendelim c)
+                         (and (closedelim c) (no indelim)))))
+            i
+            (urlend s (+ i 1) (or (opendelim c)
+                                  (and indelim (no (closedelim c)))))))))
+
+(def opendelim (c)  (in c #\< #\( #\[ #\{))
+ 
+(def closedelim (c) (in c #\> #\) #\] #\}))
+
+
+(def code-block (s i)
+  (tostring
+    (until (let left (- (len s) i 1)
+             (or (is left 0)
+                 (and (> left 2)
+                      (is (s (+ i 1)) #\newline)
+                      (nonwhite (s (+ i 2))))))
+     (writec (s (++ i))))))
+
+(def unmarkdown (s)
+  (tostring
+    (forlen i s
+      (if (litmatch "<p>" s i)
+           (do (++ i 2) 
+               (unless (is i 2) (pr "\n\n")))
+          (litmatch "<i>" s i)
+           (do (++ i 2) (pr #\*))
+          (litmatch "</i>" s i)
+           (do (++ i 3) (pr #\*))
+          (litmatch "<a href=" s i)
+           (let endurl (posmatch [in _ #\> #\space] s (+ i 9))
+             (if endurl
+                 (do (pr (cut s (+ i 9) (- endurl 1)))
+                     (= i (aif (posmatch "</a>" s endurl)
+                               (+ it 3)
+                               endurl)))
+                 (writec (s i))))
+          (litmatch "<pre><code>" s i)
+           (awhen (findsubseq "</code></pre>" s (+ i 12))
+             (pr (cut s (+ i 11) it))
+             (= i (+ it 12)))
+          (writec (s i))))))
+
+
+(def english-time (min)
+  (let n (mod min 720)
+    (string (let h (trunc (/ n 60)) (if (is h 0) "12" h))
+            ":"
+            (let m (mod n 60)
+              (if (is m 0) "00"
+                  (< m 10) (string "0" m)
+                           m))
+            (if (is min 0)   " midnight"
+                (is min 720) " noon"
+                (>= min 720) " pm"
+                             " am"))))
+
+(def parse-time (s)
+  (let (nums (o label "")) (halve s letter)
+    (with ((h (o m 0)) (map int (tokens nums ~digit))
+           cleanlabel  (downcase (rem ~alphadig label)))
+      (+ (* (if (is h 12)
+                 (if (in cleanlabel "am" "midnight")
+                     0
+                     12)
+                (is cleanlabel "am")
+                 h
+                 (+ h 12))
+            60)
+          m))))
+
+
+(= months* '("January" "February" "March" "April" "May" "June" "July"
+             "August" "September" "October" "November" "December"))
+
+(def english-date ((y m d))
+  (string d " " (months* (- m 1)) " " y))
+
+(= month-names* (obj "january"    1  "jan"        1
+                     "february"   2  "feb"        2
+                     "march"      3  "mar"        3
+                     "april"      4  "apr"        4
+                     "may"        5
+                     "june"       6  "jun"        6
+                     "july"       7  "jul"        7
+                     "august"     8  "aug"        8
+                     "september"  9  "sept"       9  "sep"      9
+                     "october"   10  "oct"       10
+                     "november"  11  "nov"       11
+                     "december"  12  "dec"       12))
+
+(def monthnum (s) (month-names* (downcase s)))
+
+; Doesn't work for BC dates.
+
+(def parse-date (s)
+  (let nums (date-nums s)
+    (if (valid-date nums)
+        nums
+        (err (string "Invalid date: " s)))))
+
+(def date-nums (s)
+  (with ((ynow mnow dnow) (date)
+         toks             (tokens s ~alphadig))
+    (if (all [all digit _] toks)
+         (let nums (map int toks)
+           (case (len nums)
+             1 (list ynow mnow (car nums))
+             2 (iflet d (find [> _ 12] nums)
+                        (list ynow (find [isnt _ d] nums) d)
+                        (cons ynow nums))
+               (if (> (car nums) 31)
+                   (firstn 3 nums)
+                   (rev (firstn 3 nums)))))
+        ([all digit _] (car toks))
+         (withs ((ds ms ys) toks
+                 d          (int ds))
+           (aif (monthnum ms)
+                (list (or (errsafe (int ys)) ynow) 
+                      it
+                      d)
+                nil))
+        (monthnum (car toks))
+         (let (ms ds ys) toks
+           (aif (errsafe (int ds))
+                (list (or (errsafe (int ys)) ynow) 
+                      (monthnum (car toks))
+                      it)
+                nil))
+          nil)))
+
+; To be correct needs to know days per month, and about leap years
+
+(def valid-date ((y m d))
+  (and y m d
+       (< 0 m 13)
+       (< 0 d 32)))
+
+(mac defopl (name parm . body)
+  `(defop ,name ,parm
+     (if (get-user ,parm)
+         (do ,@body) 
+         (login-page 'both
+                     "You need to be logged in to do that."
+                     (list (fn (u ip))
+                           (string ',name (reassemble-args ,parm)))))))
+

lib/blog.arc

@@ -0,0 +1,95 @@
+; Blog tool example.  20 Jan 08, rev 21 May 09.
+
+; To run:
+; arc> (load "blog.arc")
+; arc> (bsv)
+; go to http://localhost:8080/blog
+
+(= postdir* "arc/posts/"  maxid* 0  posts* (table))
+
+(= blogtitle* "A Blog")
+
+(deftem post  id nil  title nil  text nil)
+
+(def load-posts ()
+  (each id (map int (dir postdir*))
+    (= maxid*      (max maxid* id)
+       (posts* id) (temload 'post (string postdir* id)))))
+
+(def save-post (p) (save-table p (string postdir* p!id)))
+
+(def post (id) (posts* (errsafe:int id)))
+
+(mac blogpage body
+  `(whitepage 
+     (center
+       (widtable 600 
+         (tag b (link blogtitle* "blog"))
+         (br 3)
+         ,@body
+         (br 3)
+         (w/bars (link "archive")
+                 (link "new post" "newpost"))))))
+
+(defop viewpost req (blogop post-page req))
+
+(def blogop (f req)
+  (aif (post (arg req "id")) 
+       (f (get-user req) it) 
+       (blogpage (pr "No such post."))))
+
+(def permalink (p) (string "viewpost?id=" p!id))
+
+(def post-page (user p) (blogpage (display-post user p)))
+
+(def display-post (user p)
+  (tag b (link p!title (permalink p)))
+  (when user
+    (sp)
+    (link "[edit]" (string "editpost?id=" p!id)))
+  (br2)
+  (pr p!text))
+
+(defopl newpost req
+  (whitepage
+    (aform [let u (get-user _)
+             (post-page u (addpost u (arg _ "t") (arg _ "b")))]
+      (tab (row "title" (input "t" "" 60))
+           (row "text"  (textarea "b" 10 80))
+           (row ""      (submit))))))
+
+(def addpost (user title text)
+  (let p (inst 'post 'id (++ maxid*) 'title title 'text text)
+    (save-post p)
+    (= (posts* p!id) p)))
+
+(defopl editpost req (blogop edit-page req))
+
+(def edit-page (user p)
+  (whitepage
+    (vars-form user
+               `((string title ,p!title t t) (text text ,p!text t t))
+               (fn (name val) (= (p name) val))
+               (fn () (save-post p)
+                      (post-page user p)))))
+
+(defop archive req
+  (blogpage
+    (tag ul
+      (each p (map post (rev (range 1 maxid*)))
+        (tag li (link p!title (permalink p)))))))
+
+(defop blog req
+  (let user (get-user req)
+    (blogpage
+      (for i 0 4
+        (awhen (posts* (- maxid* i)) 
+          (display-post user it)
+          (br 3))))))
+
+(def bsv ()
+  (ensure-dir postdir*)
+  (load-posts)
+  (asv))
+
+

lib/code.arc

@@ -0,0 +1,61 @@
+; Code analysis. Spun off 21 Dec 07.
+
+; Ought to do more of this in Arc.  One of the biggest advantages
+; of Lisp is messing with code.
+
+(def codelines (file)
+  (w/infile in file
+    (summing test
+      (whilet line (readline in)
+        (test (aand (find nonwhite line) (isnt it #\;)))))))
+
+(def codeflat (file)
+  (len (flat (readall (infile file)))))
+
+(def codetree (file)
+  (treewise + (fn (x) 1) (readall (infile file))))
+
+(def code-density (file)
+  (/ (codetree file) (codelines file))) 
+
+(def tokcount (files)
+  (let counts (table)
+    (each f files
+      (each token (flat (readall (infile f)))
+        (++ (counts token 0))))
+    counts))
+
+(def common-tokens (files)
+  (let counts (tokcount files)
+    (let ranking nil
+      (maptable (fn (k v)
+                  (unless (nonop k)
+                    (insort (compare > cadr) (list k v) ranking)))
+                counts)
+      ranking)))
+
+(def nonop (x)
+  (in x 'quote 'unquote 'quasiquote 'unquote-splicing))
+
+(def common-operators (files)
+  (keep [and (isa (car _) 'sym) (bound (car _))] (common-tokens files)))
+
+(def top40 (xs)
+  (map prn (firstn 40 xs))
+  t)
+
+(def space-eaters (files)
+  (let counts (tokcount files)
+    (let ranking nil
+      (maptable (fn (k v)
+                  (when (and (isa k 'sym) (bound k))
+                    (insort (compare > [* (len (string (car _)))
+                                          (cadr _)])
+                            (list k v (* (len (string k)) v))
+                            ranking)))
+                counts)
+    ranking)))
+
+;(top40 (space-eaters allfiles*))
+
+(mac flatlen args `(len (flat ',args)))

lib/copyright

@@ -0,0 +1,2 @@
+This software is copyright (c) Paul Graham and Robert Morris.  Permission
+to use it is granted under the Perl Foundations's Artistic License 2.0.

lib/html.arc

@@ -0,0 +1,415 @@
+; HTML Utils. 
+
+
+(def color (r g b)
+  (with (c (table) 
+         f (fn (x) (if (< x 0) 0 (> x 255) 255 x)))
+    (= (c 'r) (f r) (c 'g) (f g) (c 'b) (f b))
+    c))
+
+(def dehex (str) (errsafe (coerce str 'int 16)))
+
+(defmemo hex>color (str)
+  (and (is (len str) 6)
+       (with (r (dehex (cut str 0 2))
+              g (dehex (cut str 2 4))
+              b (dehex (cut str 4 6)))
+         (and r g b
+              (color r g b)))))
+
+(defmemo gray (n) (color n n n))
+
+(= white    (gray 255) 
+   black    (gray 0)
+   linkblue (color 0 0 190)
+   orange   (color 255 102 0)
+   darkred  (color 180 0 0)
+   darkblue (color 0 0 120)
+   )
+
+(= opmeths* (table))
+
+(mac opmeth args
+  `(opmeths* (list ,@args)))
+
+(mac attribute (tag opt f)
+  `(= (opmeths* (list ',tag ',opt)) ,f))
+
+(= hexreps (table))
+
+(for i 0 255 (= (hexreps i)
+                (let s (coerce i 'string 16)
+                  (if (is (len s) 1) (+ "0" s) s))))
+
+(defmemo hexrep (col)
+  (+ (hexreps (col 'r)) (hexreps (col 'g)) (hexreps (col 'b))))
+
+(def opcolor (key val) 
+  (w/uniq gv
+    `(whenlet ,gv ,val
+       (pr ,(string " " key "=#") (hexrep ,gv)))))
+
+(def opstring (key val)
+  `(aif ,val (pr ,(+ " " key "=\"") it #\")))
+
+(def opnum (key val)
+  `(aif ,val (pr ,(+ " " key "=") it)))
+
+(def opsym (key val)
+  `(pr ,(+ " " key "=") ,val))
+
+(def opsel (key val)
+  `(if ,val (pr " selected")))
+
+(def opcheck (key val)
+  `(if ,val (pr " checked")))
+
+(def opesc (key val)
+  `(awhen ,val
+     (pr ,(string " " key "=\""))
+     (if (isa it 'string) (pr-escaped it) (pr it))
+     (pr  #\")))
+
+; need to escape more?  =?
+
+(def pr-escaped (x)
+  (each c x 
+    (pr (case c #\<  "&#60;"  
+                #\>  "&#62;"  
+                #\"  "&#34;"  
+                #\&  "&#38;"
+                c))))
+
+(attribute a          href           opstring)
+(attribute a          rel            opstring)
+(attribute a          class          opstring)
+(attribute a          id             opsym)
+(attribute a          onclick        opstring)
+(attribute body       alink          opcolor)
+(attribute body       bgcolor        opcolor)
+(attribute body       leftmargin     opnum)
+(attribute body       link           opcolor)
+(attribute body       marginheight   opnum)
+(attribute body       marginwidth    opnum)
+(attribute body       topmargin      opnum)
+(attribute body       vlink          opcolor)
+(attribute font       color          opcolor)
+(attribute font       face           opstring)
+(attribute font       size           opnum)
+(attribute form       action         opstring)
+(attribute form       method         opsym)
+(attribute img        align          opsym)
+(attribute img        border         opnum)
+(attribute img        height         opnum)
+(attribute img        width          opnum)
+(attribute img        vspace         opnum)
+(attribute img        hspace         opnum)
+(attribute img        src            opstring)
+(attribute input      name           opstring)
+(attribute input      size           opnum)
+(attribute input      type           opsym)
+(attribute input      value          opesc)
+(attribute input      checked        opcheck)
+(attribute select     name           opstring)
+(attribute option     selected       opsel)
+(attribute table      bgcolor        opcolor)
+(attribute table      border         opnum)
+(attribute table      cellpadding    opnum)
+(attribute table      cellspacing    opnum)
+(attribute table      width          opstring)
+(attribute textarea   cols           opnum)
+(attribute textarea   name           opstring)
+(attribute textarea   rows           opnum)
+(attribute textarea   wrap           opsym)
+(attribute td         align          opsym)
+(attribute td         bgcolor        opcolor)
+(attribute td         colspan        opnum)
+(attribute td         width          opnum)
+(attribute td         valign         opsym)
+(attribute td         class          opstring)
+(attribute tr         bgcolor        opcolor)
+(attribute hr         color          opcolor)
+(attribute span       class          opstring)
+(attribute span       align          opstring)
+(attribute span       id             opsym)
+(attribute rss        version        opstring)
+
+
+(mac gentag args (start-tag args))
+     
+(mac tag (spec . body)
+  `(do ,(start-tag spec)
+       ,@body
+       ,(end-tag spec)))
+     
+(mac tag-if (test spec . body)
+  `(if ,test
+       (tag ,spec ,@body)
+       (do ,@body)))
+
+(def start-tag (spec)
+  (if (atom spec)
+      `(pr ,(string "<" spec ">"))
+      (let opts (tag-options (car spec) (pair (cdr spec)))
+        (if (all [isa _ 'string] opts)
+            `(pr ,(string "<" (car spec) (apply string opts) ">"))
+            `(do (pr ,(string "<" (car spec)))
+                 ,@(map (fn (opt)
+                          (if (isa opt 'string)
+                              `(pr ,opt)
+                              opt))
+                        opts)
+                 (pr ">"))))))
+
+(def end-tag (spec)
+  `(pr ,(string "</" (carif spec) ">")))
+
+(def literal (x) 
+  (case (type x)
+    sym   (in x nil t)
+    cons  (caris x 'quote)
+          t))
+
+; Returns a list whose elements are either strings, which can 
+; simply be printed out, or expressions, which when evaluated
+; generate output.
+
+(def tag-options (spec options)
+  (if (no options)
+      '()
+      (let ((opt val) . rest) options
+        (let meth (if (is opt 'style) opstring (opmeth spec opt))
+          (if meth
+              (if val
+                  (cons (if (precomputable-tagopt val)
+                            (tostring (eval (meth opt val)))
+                            (meth opt val))
+                        (tag-options spec rest))
+                  (tag-options spec rest))
+              (do
+                (pr "<!-- ignoring " opt " for " spec "-->")
+                (tag-options spec rest)))))))
+
+(def precomputable-tagopt (val)
+  (and (literal val) 
+       (no (and (is (type val) 'string) (find #\@ val)))))
+
+(def br ((o n 1)) 
+  (repeat n (pr "<br>")) 
+  (prn))
+
+(def br2 () (prn "<br><br>"))
+
+(mac center    body         `(tag center ,@body))
+(mac underline body         `(tag u ,@body))
+(mac tab       body         `(tag (table border 0) ,@body))
+(mac tr        body         `(tag tr ,@body))
+
+(let pratoms (fn (body)
+               (if (or (no body) 
+                       (all [and (acons _) (isnt (car _) 'quote)]
+                            body))
+                   body
+                   `((pr ,@body))))
+
+  (mac td       body         `(tag td ,@(pratoms body)))
+  (mac trtd     body         `(tr (td ,@(pratoms body))))
+  (mac tdr      body         `(tag (td align 'right) ,@(pratoms body)))
+  (mac tdcolor  (col . body) `(tag (td bgcolor ,col) ,@(pratoms body)))
+)
+
+(mac row args
+  `(tr ,@(map [list 'td _] args)))
+
+(mac prrow args
+  (w/uniq g
+    `(tr ,@(map (fn (a) 
+                  `(let ,g ,a
+                     (if (number ,g)
+                         (tdr (pr ,g))
+                         (td (pr ,g)))))
+                 args))))
+
+(mac prbold body `(tag b (pr ,@body)))
+
+(def para args 
+  (gentag p)
+  (when args (apply pr args)))
+
+(def menu (name items (o sel nil))
+  (tag (select name name)
+    (each i items
+      (tag (option selected (is i sel))
+        (pr i)))))
+
+(mac whitepage body
+  `(tag html 
+     (tag (body bgcolor white alink linkblue) ,@body)))
+
+(def errpage args (whitepage (apply prn args)))
+
+(def blank-url () "s.gif")
+
+; Could memoize these.
+
+; If h = 0, doesn't affect table column widths in some Netscapes.
+
+(def hspace (n)    (gentag img src (blank-url) height 1 width n))
+(def vspace (n)    (gentag img src (blank-url) height n width 0))
+(def vhspace (h w) (gentag img src (blank-url) height h width w))
+
+(mac new-hspace (n)    
+  (if (number n)
+      `(pr ,(string "<span style=\"padding-left:" n "px\" />"))
+      `(pr "<span style=\"padding-left:" ,n "px\" />")))
+
+;(def spacerow (h) (tr (td (vspace h))))
+
+(def spacerow (h) (pr "<tr style=\"height:" h "px\"></tr>"))
+
+; For use as nested table.
+
+(mac zerotable body
+  `(tag (table border 0 cellpadding 0 cellspacing 0)
+     ,@body))
+
+; was `(tag (table border 0 cellpadding 0 cellspacing 7) ,@body)
+
+(mac sptab body
+  `(tag (table style "border-spacing: 7px 0px;") ,@body))
+
+(mac widtable (w . body)
+  `(tag (table width ,w) (tr (td ,@body))))
+
+(def cellpr (x) (pr (or x "&nbsp;")))
+
+(def but ((o text "submit") (o name nil))
+  (gentag input type 'submit name name value text))
+
+(def submit ((o val "submit"))
+  (gentag input type 'submit value val))
+
+(def buts (name . texts)
+  (if (no texts)
+      (but)
+      (do (but (car texts) name)
+          (each text (cdr texts)
+            (pr " ")
+            (but text name)))))
+
+(mac spanrow (n . body)
+  `(tr (tag (td colspan ,n) ,@body)))
+
+(mac form (action . body)
+  `(tag (form method "post" action ,action) ,@body))
+
+(mac textarea (name rows cols . body)
+  `(tag (textarea name ,name rows ,rows cols ,cols) ,@body))
+
+(def input (name (o val "") (o size 10))
+  (gentag input type 'text name name value val size size))
+
+(mac inputs args
+  `(tag (table border 0)
+     ,@(map (fn ((name label len text))
+              (w/uniq (gl gt)
+                `(let ,gl ,len
+                   (tr (td (pr ',label ":"))
+                       (if (isa ,gl 'cons)
+                           (td (textarea ',name (car ,gl) (cadr ,gl)
+                                 (let ,gt ,text (if ,gt (pr ,gt)))))
+                           (td (gentag input type ',(if (is label 'password) 
+                                                    'password 
+                                                    'text)
+                                         name ',name 
+                                         size ,len 
+                                         value ,text)))))))
+            (tuples args 4))))
+
+(def single-input (label name chars btext (o pwd))
+  (pr label)
+  (gentag input type (if pwd 'password 'text) name name size chars)
+  (sp)
+  (submit btext))
+
+(mac cdata body
+  `(do (pr "<![CDATA[") 
+       ,@body
+       (pr "]]>")))
+
+(def eschtml (str)
+  (tostring 
+    (each c str
+      (pr (case c #\<  "&#60;" 
+                  #\>  "&#62;"
+                  #\"  "&#34;"
+                  #\'  "&#39;"
+                  #\&  "&#38;"
+                        c)))))
+
+(def esc-tags (str)
+  (tostring 
+    (each c str
+      (pr (case c #\<  "&#60;" 
+                  #\>  "&#62;"
+                  #\&  "&#38;"
+                        c)))))
+
+(def nbsp () (pr "&nbsp;"))
+
+(def link (text (o dest text) (o color))
+  (tag (a href dest) 
+    (tag-if color (font color color)
+      (pr text))))
+
+(def underlink (text (o dest text))
+  (tag (a href dest) (tag u (pr text))))
+
+(def striptags (s)
+  (let intag nil
+    (tostring
+      (each c s
+        (if (is c #\<) (set intag)
+            (is c #\>) (wipe intag)
+            (no intag) (pr c))))))
+
+(def clean-url (u)
+  (rem [in _ #\" #\' #\< #\>] u))
+
+(def shortlink (url)
+  (unless (or (no url) (< (len url) 7))
+    (link (cut url 7) url)))
+
+; this should be one regexp
+
+(def parafy (str)
+  (let ink nil
+    (tostring
+      (each c str
+        (pr c)
+        (unless (whitec c) (set ink))
+        (when (is c #\newline)
+          (unless ink (pr "<p>"))
+          (wipe ink))))))
+
+(mac spanclass (name . body)
+  `(tag (span class ',name) ,@body))
+
+(def pagemessage (text)
+  (when text (prn text) (br2)))
+
+; Could be stricter.  Memoized because looking for chars in Unicode
+; strings is terribly inefficient in Mzscheme.
+
+(defmemo valid-url (url)
+  (and (len> url 10)
+       (or (begins url "http://")
+           (begins url "https://"))
+       (~find [in _ #\< #\> #\" #\'] url)))
+
+(mac fontcolor (c . body)
+  (w/uniq g
+    `(let ,g ,c
+       (if ,g
+           (tag (font color ,g) ,@body)
+           (do ,@body)))))

lib/libs.arc

@@ -0,0 +1,7 @@
+(map load '("strings.arc"
+            "pprint.arc"
+            "code.arc"
+            "html.arc"
+            "srv.arc"
+            "app.arc"
+            "prompt.arc"))

lib/pprint.arc

@@ -0,0 +1,80 @@
+; Pretty-Printing.  Spun off 4 Aug 06.
+
+; todo: indentation of long ifs; quasiquote, unquote, unquote-splicing
+           
+(= bodops* (fill-table (table)
+   '(let 2 with 1 while 1 def 2 fn 1 rfn 2 afn 1
+     when 1 unless 1 after 1 whilet 2 for 3 each 2 whenlet 2 awhen 1
+     whitepage 0 tag 1 form 1 aform 1 aformh 1 w/link 1 textarea 3
+   )))
+
+(= oneline* 35) ; print exprs less than this long on one line
+
+; If returns nil, can assume it didn't have to break expr.
+  
+(def ppr (expr (o col 0) (o noindent nil))
+  (if (or (atom expr) (dotted expr))
+       (do (unless noindent (sp col))
+           (write expr)
+           nil)
+      (is (car expr) 'quote)
+       (do (unless noindent (sp col))
+           (pr "'")
+           (ppr (cadr expr) (+ col 1) t))
+      (bodops* (car expr))
+       (do (unless noindent (sp col))
+           (let whole (tostring (write expr))
+             (if (< (len whole) oneline*)
+                 (do (pr whole) nil)
+                 (ppr-progn expr col noindent))))
+      (do (unless noindent (sp col))
+          (let whole (tostring (write expr))
+            (if (< (len whole) oneline*)
+                (do (pr whole) nil)
+                (ppr-call expr col noindent))))))
+
+(def ppr-progn (expr col noindent)
+  (lpar)
+  (let n (bodops* (car expr))
+    (let str (tostring (write-spaced (firstn n expr)))
+      (unless (is n 0) (pr str) (sp))
+      (ppr (expr n) (+ col (len str) 2) t))
+    (map (fn (e) (prn) (ppr e (+ col 2)))
+         (nthcdr (+ n 1) expr)))
+  (rpar)
+  t)
+             
+(def ppr-call (expr col noindent)
+  (lpar)
+  (let carstr (tostring (write (car expr)))
+    (pr carstr)
+    (if (cdr expr)
+        (do (sp)
+            (let broke (ppr (cadr expr) (+ col (len carstr) 2) t)
+              (pprest (cddr expr)
+                      (+ col (len carstr) 2)
+                      (no broke)))
+            t)
+        (do (rpar) t))))
+       
+(def pprest (exprs col (o oneline t))
+  (if (and oneline
+           (all (fn (e)
+                  (or (atom e) (and (is (car e) 'quote) (atom (cadr e)))))
+                exprs))
+      (do (map (fn (e) (pr " ") (write e))
+               exprs)
+          (rpar))
+      (do (when exprs
+            (each e exprs (prn) (ppr e col)))
+          (rpar))))
+                
+(def write-spaced (xs)
+  (when xs
+    (write (car xs))
+    (each x (cdr xs) (pr " ") (write x))))
+  
+(def sp ((o n 1)) (repeat n (pr " ")))
+(def lpar () (pr "("))
+(def rpar () (pr ")"))
+

lib/prompt.arc

@@ -0,0 +1,119 @@
+; Prompt: Web-based programming application.  4 Aug 06.
+
+(= appdir* "arc/apps/")
+
+(defop prompt req 
+  (let user (get-user req)
+    (if (admin user)
+        (prompt-page user)
+        (pr "Sorry."))))
+
+(def prompt-page (user . msg)
+  (ensure-dir appdir*)
+  (ensure-dir (string appdir* user))
+  (whitepage
+    (prbold "Prompt")
+    (hspace 20)
+    (pr user " | ")
+    (link "logout")
+    (when msg (hspace 10) (apply pr msg))
+    (br2)
+    (tag (table border 0 cellspacing 10)
+      (each app (dir (+ appdir* user))
+        (tr (td app)
+            (td (ulink user 'edit   (edit-app user app)))
+            (td (ulink user 'run    (run-app  user app)))
+            (td (hspace 40)
+                (ulink user 'delete (rem-app  user app))))))
+    (br2)
+    (aform (fn (req)
+             (when-umatch user req
+               (aif (goodname (arg req "app"))
+                    (edit-app user it)
+                    (prompt-page user "Bad name."))))
+       (tab (row "name:" (input "app") (submit "create app"))))))
+
+(def app-path (user app) 
+  (and user app (+ appdir* user "/" app)))
+
+(def read-app (user app)
+  (aand (app-path user app) 
+        (file-exists it)
+        (readfile it)))
+
+(def write-app (user app exprs)
+  (awhen (app-path user app)
+    (w/outfile o it 
+      (each e exprs (write e o)))))
+
+(def rem-app (user app)
+  (let file (app-path user app)
+    (if (file-exists file)
+        (do (rmfile (app-path user app))
+            (prompt-page user "Program " app " deleted."))
+        (prompt-page user "No such app."))))
+
+(def edit-app (user app)
+  (whitepage
+    (pr "user: " user " app: " app)
+    (br2)
+    (aform (fn (req)
+             (let u2 (get-user req)
+               (if (is u2 user)
+                   (do (when (is (arg req "cmd") "save")
+                         (write-app user app (readall (arg req "exprs"))))
+                       (prompt-page user))
+                   (login-page 'both nil
+                               (fn (u ip) (prompt-page u))))))
+      (textarea "exprs" 10 82
+        (pprcode (read-app user app)))
+      (br2)
+      (buts 'cmd "save" "cancel"))))
+
+(def pprcode (exprs) 
+  (each e exprs
+    (ppr e) 
+    (pr "\n\n")))
+
+(def view-app (user app)
+  (whitepage
+    (pr "user: " user " app: " app)
+    (br2)
+    (tag xmp (pprcode (read-app user app)))))
+
+(def run-app (user app)
+  (let exprs (read-app user app)
+    (if exprs 
+        (on-err (fn (c) (pr "Error: " (details c)))
+          (fn () (map eval exprs)))
+        (prompt-page user "Error: No application " app " for user " user))))
+
+(wipe repl-history*)
+
+(defop repl req
+  (if (admin (get-user req))
+      (replpage req)
+      (pr "Sorry.")))
+
+(def replpage (req)
+  (whitepage
+    (repl (readall (or (arg req "expr") "")) "repl")))
+
+(def repl (exprs url)
+    (each expr exprs 
+      (on-err (fn (c) (push (list expr c t) repl-history*))
+              (fn () 
+                (= that (eval expr) thatexpr expr)
+                (push (list expr that) repl-history*))))
+    (form url
+      (textarea "expr" 8 60)
+      (sp) 
+      (submit))
+    (tag xmp
+      (each (expr val err) (firstn 20 repl-history*)
+        (pr "> ")
+        (ppr expr)
+        (prn)
+        (prn (if err "Error: " "")
+             (ellipsize (tostring (write val)) 800)))))
+

lib/srv.arc

@@ -0,0 +1,573 @@
+; HTTP Server.
+
+; To improve performance with static files, set static-max-age*.
+
+(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")
+
+(= quitsrv* nil breaksrv* nil) 
+
+(def serve ((o port 8080))
+  (wipe quitsrv*)
+  (ensure-srvdirs)
+  (map [apply new-bgthread _] pending-bgthreads*)
+  (w/socket s port
+    (setuid 2) ; XXX switch from root to pg
+    (prn "ready to serve port " port)
+    (flushout)
+    (= currsock* s)
+    (until quitsrv*
+      (handle-request s breaksrv*)))
+  (prn "quit server"))
+
+(def serve1 ((o port 8080))
+  (w/socket s port (handle-request s t)))
+
+(def ensure-srvdirs ()
+  (map ensure-dir (list arcdir* logdir* staticdir*)))
+
+(= srv-noisy* nil)
+
+; http requests currently capped at 2 meg by socket-accept
+
+; should threads process requests one at a time? no, then
+; a browser that's slow consuming the data could hang the
+; whole server.
+
+; wait for a connection from a browser and start a thread
+; to handle it. also arrange to kill that thread if it
+; has not completed in threadlife* seconds.
+
+(= threadlife* 30  requests* 0  requests/ip* (table)  
+   throttle-ips* (table)  ignore-ips* (table)  spurned* (table))
+
+(def handle-request (s breaksrv)
+  (if breaksrv
+      (handle-request-1 s)
+      (errsafe (handle-request-1 s))))
+
+(def handle-request-1 (s)
+  (let (i o ip) (socket-accept s)
+    (if (and (or (ignore-ips* ip) (abusive-ip ip))
+             (++ (spurned* ip 0)))
+        (force-close i o)
+        (do (++ requests*)
+            (++ (requests/ip* ip 0))
+            (with (th1 nil th2 nil)
+              (= th1 (thread
+                       (after (handle-request-thread i o ip)
+                              (close i o)
+                              (kill-thread th2))))
+              (= th2 (thread
+                       (sleep threadlife*)
+                       (unless (dead th1)
+                         (prn "srv thread took too long for " ip))
+                       (break-thread th1)
+                       (force-close i o))))))))
+
+; Returns true if ip has made req-limit* requests in less than
+; req-window* seconds.  If an ip is throttled, only 1 request is 
+; allowed per req-window* seconds.  If an ip makes req-limit* 
+; requests in less than dos-window* seconds, it is a treated as a DoS
+; attack and put in ignore-ips* (for this server invocation).
+
+; To adjust this while running, adjust the req-window* time, not 
+; req-limit*, because algorithm doesn't enforce decreases in the latter.
+
+(= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2)
+
+(def abusive-ip (ip)
+  (and (only.> (requests/ip* ip) 250)
+       (let now (seconds)
+         (do1 (if (req-times* ip)
+                  (and (>= (qlen (req-times* ip)) 
+                           (if (throttle-ips* ip) 1 req-limit*))
+                       (let dt (- now (deq (req-times* ip)))
+                         (if (< dt dos-window*) (set (ignore-ips* ip)))
+                         (< dt req-window*)))
+                  (do (= (req-times* ip) (queue))
+                      nil))
+              (enq now (req-times* ip))))))
+
+(def handle-request-thread (i o ip)
+  (with (nls 0 lines nil line nil responded nil t0 (msec))
+    (after
+      (whilet c (unless responded (readc i))
+        (if srv-noisy* (pr c))
+        (if (is c #\newline)
+            (if (is (++ nls) 2) 
+                (let (type op args n cooks) (parseheader (rev lines))
+                  (let t1 (msec)
+                    (case type
+                      get  (respond o op args cooks ip)
+                      post (handle-post i o op args n cooks ip)
+                           (respond-err o "Unknown request: " (car lines)))
+                    (log-request type op args cooks ip t0 t1)
+                    (set responded)))
+                (do (push (string (rev line)) lines)
+                    (wipe line)))
+            (unless (is c #\return)
+              (push c line)
+              (= nls 0))))
+      (close i o)))
+  (harvest-fnids))
+
+(def log-request (type op args cooks ip t0 t1)
+  (with (parsetime (- t1 t0) respondtime (- (msec) t1))
+    (srvlog 'srv ip 
+                 parsetime 
+                 respondtime 
+                 (if (> (+ parsetime respondtime) 1000) "***" "")
+                 type
+                 op
+                 (let arg1 (car args)
+                   (if (caris arg1 "fnid") "" arg1))
+                 cooks)))
+
+; Could ignore return chars (which come from textarea fields) here by
+; (unless (is c #\return) (push c line))
+
+(def handle-post (i o op args n cooks ip)
+  (if srv-noisy* (pr "Post Contents: "))
+  (if (no n)
+      (respond-err o "Post request without Content-Length.")
+      (let line nil
+        (whilet c (and (> n 0) (readc i))
+          (if srv-noisy* (pr c))
+          (-- n)
+          (push c line)) 
+        (if srv-noisy* (pr "\n\n"))
+        (respond o op (+ (parseargs (string (rev line))) args) cooks ip))))
+
+(= header* "HTTP/1.1 200 OK
+Content-Type: text/html; charset=utf-8
+Connection: close")
+
+(= type-header* (table))
+
+(def gen-type-header (ctype)
+  (+ "HTTP/1.0 200 OK
+Content-Type: "
+     ctype
+     "
+Connection: close"))
+
+(map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
+     '((gif       "image/gif")
+       (jpg       "image/jpeg")
+       (png       "image/png")
+       (text/html "text/html; charset=utf-8")))
+
+(= rdheader* "HTTP/1.0 302 Moved")
+
+(= srvops* (table) redirector* (table) optimes* (table) opcounts* (table))
+
+(def save-optime (name elapsed)
+  ; this is the place to put a/b testing
+  ; toggle a flag and push elapsed into one of two lists
+  (++ (opcounts* name 0))
+  (unless (optimes* name) (= (optimes* name) (queue)))
+  (enq-limit elapsed (optimes* name) 1000))
+
+; For ops that want to add their own headers.  They must thus remember 
+; to prn a blank line before anything meant to be part of the page.
+
+(mac defop-raw (name parms . body)
+  (w/uniq t1
+    `(= (srvops* ',name) 
+        (fn ,parms 
+          (let ,t1 (msec)
+            (do1 (do ,@body)
+                 (save-optime ',name (- (msec) ,t1))))))))
+
+(mac defopr-raw (name parms . body)
+  `(= (redirector* ',name) t
+      (srvops* ',name)     (fn ,parms ,@body)))
+
+(mac defop (name parm . body)
+  (w/uniq gs
+    `(do (wipe (redirector* ',name))
+         (defop-raw ,name (,gs ,parm) 
+           (w/stdout ,gs (prn) ,@body)))))
+
+; Defines op as a redirector.  Its retval is new location.
+
+(mac defopr (name parm . body)
+  (w/uniq gs
+    `(do (set (redirector* ',name))
+         (defop-raw ,name (,gs ,parm)
+           ,@body))))
+
+;(mac testop (name . args) `((srvops* ',name) ,@args))
+
+(deftem request
+  args  nil
+  cooks nil
+  ip    nil)
+
+(= unknown-msg* "Unknown." max-age* (table) static-max-age* nil)
+
+(def respond (str op args cooks ip)
+  (w/stdout str
+    (iflet f (srvops* op)
+           (let req (inst 'request 'args args 'cooks cooks 'ip ip)
+             (if (redirector* op)
+                 (do (prn rdheader*)
+                     (prn "Location: " (f str req))
+                     (prn))
+                 (do (prn header*)
+                     (awhen (max-age* op)
+                       (prn "Cache-Control: max-age=" it))
+                     (f str req))))
+           (let filetype (static-filetype op)
+             (aif (and filetype (file-exists (string staticdir* op)))
+                  (do (prn (type-header* filetype))
+                      (awhen static-max-age*
+                        (prn "Cache-Control: max-age=" it))
+                      (prn)
+                      (w/infile i it
+                        (whilet b (readb i)
+                          (writeb b str))))
+                  (respond-err str unknown-msg*))))))
+
+(def static-filetype (sym)
+  (let fname (coerce sym 'string)
+    (and (~find #\/ fname)
+         (case (downcase (last (check (tokens fname #\.) ~single)))
+           "gif"  'gif
+           "jpg"  'jpg
+           "jpeg" 'jpg
+           "png"  'png
+           "css"  'text/html
+           "txt"  'text/html
+           "htm"  'text/html
+           "html" 'text/html
+           "arc"  'text/html
+           ))))
+
+(def respond-err (str msg . args)
+  (w/stdout str
+    (prn header*)
+    (prn)
+    (apply pr msg args)))
+
+(def parseheader (lines)
+  (let (type op args) (parseurl (car lines))
+    (list type
+          op
+          args
+          (and (is type 'post)
+               (some (fn (s)
+                       (and (begins s "Content-Length:")
+                            (errsafe:coerce (cadr (tokens s)) 'int)))
+                     (cdr lines)))
+          (some (fn (s)
+                  (and (begins s "Cookie:")
+                       (parsecookies s)))
+                (cdr lines)))))
+
+; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))
+
+(def parseurl (s)
+  (let (type url) (tokens s)
+    (let (base args) (tokens url #\?)
+      (list (sym (downcase type))
+            (sym (cut base 1))
+            (if args
+                (parseargs args)
+                nil)))))
+
+; I don't urldecode field names or anything in cookies; correct?
+
+(def parseargs (s)
+  (map (fn ((k v)) (list k (urldecode v)))
+       (map [tokens _ #\=] (tokens s #\&))))
+
+(def parsecookies (s)
+  (map [tokens _ #\=] 
+       (cdr (tokens s [or (whitec _) (is _ #\;)]))))
+
+(def arg (req key) (alref req!args key))
+
+; *** Warning: does not currently urlencode args, so if need to do
+; that replace v with (urlencode v).
+
+(def reassemble-args (req)
+  (aif req!args
+       (apply string "?" (intersperse '&
+                                      (map (fn ((k v))
+                                             (string k '= v))
+                                           it)))
+       ""))
+
+(= fns* (table) fnids* nil timed-fnids* nil)
+
+; count on huge (expt 64 10) size of fnid space to avoid clashes
+
+(def new-fnid ()
+  (check (sym (rand-string 10)) ~fns* (new-fnid)))
+
+(def fnid (f)
+  (atlet key (new-fnid)
+    (= (fns* key) f)
+    (push key fnids*)
+    key))
+
+(def timed-fnid (lasts f)
+  (atlet key (new-fnid)
+    (= (fns* key) f)
+    (push (list key (seconds) lasts) timed-fnids*)
+    key))
+
+; Within f, it will be bound to the fn's own fnid.  Remember that this is
+; so low-level that need to generate the newline to separate from the headers
+; within the body of f.
+
+(mac afnid (f)
+  `(atlet it (new-fnid)
+     (= (fns* it) ,f)
+     (push it fnids*)
+     it))
+
+;(defop test-afnid req
+;  (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
+;    (pr "click here")))
+
+; To be more sophisticated, instead of killing fnids, could first 
+; replace them with fns that tell the server it's harvesting too 
+; aggressively if they start to get called.  But the right thing to 
+; do is estimate what the max no of fnids can be and set the harvest 
+; limit there-- beyond that the only solution is to buy more memory.
+
+(def harvest-fnids ((o n 50000))  ; was 20000
+  (when (len> fns* n) 
+    (pull (fn ((id created lasts))
+            (when (> (since created) lasts)    
+              (wipe (fns* id))
+              t))
+          timed-fnids*)
+    (atlet nharvest (trunc (/ n 10))
+      (let (kill keep) (split (rev fnids*) nharvest)
+        (= fnids* (rev keep)) 
+        (each id kill 
+          (wipe (fns* id)))))))
+
+(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")
+
+(= dead-msg* "\nUnknown or expired link.")
+ 
+(defop-raw x (str req)
+  (w/stdout str 
+    (aif (fns* (sym (arg req "fnid")))
+         (it req)
+         (pr dead-msg*))))
+
+(defopr-raw y (str req)
+  (aif (fns* (sym (arg req "fnid")))
+       (w/stdout str (it req))
+       "deadlink"))
+
+; For asynchronous calls; discards the page.  Would be better to tell
+; the fn not to generate it.
+
+(defop-raw a (str req)
+  (aif (fns* (sym (arg req "fnid")))
+       (tostring (it req))))
+
+(defopr r req
+  (aif (fns* (sym (arg req "fnid")))
+       (it req)
+       "deadlink"))
+
+(defop deadlink req
+  (pr dead-msg*))
+
+(def url-for (fnid)
+  (string fnurl* "?fnid=" fnid))
+
+(def flink (f)
+  (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))
+
+(def rflink (f)
+  (string rfnurl* "?fnid=" (fnid f)))
+  
+; Since it's just an expr, gensym a parm for (ignored) args.
+
+(mac w/link (expr . body)
+  `(tag (a href (flink (fn (,(uniq)) ,expr)))
+     ,@body))
+
+(mac w/rlink (expr . body)
+  `(tag (a href (rflink (fn (,(uniq)) ,expr)))
+     ,@body))
+
+(mac onlink (text . body)
+  `(w/link (do ,@body) (pr ,text)))
+
+(mac onrlink (text . body)
+  `(w/rlink (do ,@body) (pr ,text)))
+
+; bad to have both flink and linkf; rename flink something like fnid-link
+
+(mac linkf (text parms . body)
+  `(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))
+
+(mac rlinkf (text parms . body)
+  `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))
+
+;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))
+
+;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))
+
+(mac w/link-if (test expr . body)
+  `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
+     ,@body))
+
+(def fnid-field (id)
+  (gentag input type 'hidden name 'fnid value id))
+
+; f should be a fn of one arg, which will be http request args.
+
+(def fnform (f bodyfn (o redir))
+  (tag (form method 'post action (if redir rfnurl2* fnurl*))
+    (fnid-field (fnid f))
+    (bodyfn)))
+
+; Could also make a version that uses just an expr, and var capture.
+; Is there a way to ensure user doesn't use "fnid" as a key?
+
+(mac aform (f . body)
+  (w/uniq ga
+    `(tag (form method 'post action fnurl*)
+       (fnid-field (fnid (fn (,ga)
+                           (prn)
+                           (,f ,ga))))
+       ,@body)))
+
+;(defop test1 req
+;  (fnform (fn (req) (prn) (pr req))
+;          (fn () (single-input "" 'foo 20 "submit"))))
+ 
+;(defop test2 req
+;  (aform (fn (req) (pr req))
+;    (single-input "" 'foo 20 "submit")))
+
+; Like aform except creates a fnid that will last for lasts seconds
+; (unless the server is restarted).
+
+(mac taform (lasts f . body)
+  (w/uniq (gl gf gi ga)
+    `(withs (,gl ,lasts
+             ,gf (fn (,ga) (prn) (,f ,ga)))
+       (tag (form method 'post action fnurl*)
+         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
+         ,@body))))
+
+(mac arform (f . body)
+  `(tag (form method 'post action rfnurl*)
+     (fnid-field (fnid ,f))
+     ,@body))
+
+; overlong
+
+(mac tarform (lasts f . body)
+  (w/uniq (gl gf)
+    `(withs (,gl ,lasts ,gf ,f)
+       (tag (form method 'post action rfnurl*)
+         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
+         ,@body))))
+
+(mac aformh (f . body)
+  `(tag (form method 'post action fnurl*)
+     (fnid-field (fnid ,f))
+     ,@body))
+
+(mac arformh (f . body)
+  `(tag (form method 'post action rfnurl2*)
+     (fnid-field (fnid ,f))
+     ,@body))
+
+; only unique per server invocation
+
+(= unique-ids* (table))
+
+(def unique-id ((o len 8))
+  (let id (sym (rand-string (max 5 len)))
+    (if (unique-ids* id)
+        (unique-id)
+        (= (unique-ids* id) id))))
+
+(def srvlog (type . args)
+  (w/appendfile o (logfile-name type)
+    (w/stdout o (atomic (apply prs (seconds) args) (prn)))))
+
+(def logfile-name (type)
+  (string logdir* type "-" (memodate)))
+
+(with (lastasked nil lastval nil)
+
+(def memodate ()
+  (let now (seconds)
+    (if (or (no lastasked) (> (- now lastasked) 60))
+        (= lastasked now lastval (datestring))
+        lastval)))
+
+)
+
+(defop || req (pr "It's alive."))
+
+(defop topips req
+  (when (admin (get-user req))
+    (whitepage
+      (sptab
+        (each ip (let leaders nil 
+                   (maptable (fn (ip n)
+                               (when (> n 100)
+                                 (insort (compare > requests/ip*)
+                                         ip
+                                         leaders)))
+                             requests/ip*)
+                   leaders)
+          (let n (requests/ip* ip)
+            (row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))
+
+(defop spurned req
+  (when (admin (get-user req))
+    (whitepage
+      (sptab
+        (map (fn ((ip n)) (row ip n))
+             (sortable spurned*))))))
+
+; eventually promote to general util
+
+(def sortable (ht (o f >))
+  (let res nil
+    (maptable (fn kv
+                (insort (compare f cadr) kv res))
+              ht)
+    res))
+
+
+; Background Threads
+
+(= bgthreads* (table) pending-bgthreads* nil)
+
+(def new-bgthread (id f sec)
+  (aif (bgthreads* id) (break-thread it))
+  (= (bgthreads* id) (new-thread (fn () 
+                                   (while t
+                                     (sleep sec)
+                                     (f))))))
+
+; should be a macro for this?
+
+(mac defbg (id sec . body)
+  `(do (pull [caris _ ',id] pending-bgthreads*)
+       (push (list ',id (fn () ,@body) ,sec) 
+             pending-bgthreads*)))
+
+
+
+; Idea: make form fields that know their value type because of
+; gensymed names, and so the receiving fn gets args that are not
+; strings but parsed values.
+

lib/strings.arc

@@ -0,0 +1,226 @@
+; Matching.  Spun off 29 Jul 06.
+
+; arc> (tostring (writec (coerce 133 'char)))
+;
+;> (define ss (open-output-string))
+;> (write-char (integer->char 133) ss)
+;> (get-output-string ss)
+;"\u0085"
+
+(def tokens (s (o sep whitec))
+  (let test (testify sep)
+    (let rec (afn (cs toks tok)
+               (if (no cs)         (consif tok toks)
+                   (test (car cs)) (self (cdr cs) (consif tok toks) nil)
+                                   (self (cdr cs) toks (cons (car cs) tok))))
+      (rev (map [coerce _ 'string]
+                (map rev (rec (coerce s 'cons) nil nil)))))))
+
+; names of cut, split, halve not optimal
+
+(def halve (s (o sep whitec))
+  (let test (testify sep)
+    (let rec (afn (cs tok)
+               (if (no cs)         (list (rev tok))
+                   (test (car cs)) (list cs (rev tok))
+                                   (self (cdr cs) (cons (car cs) tok))))
+      (rev (map [coerce _ 'string]
+                (rec (coerce s 'cons) nil))))))
+
+; maybe promote to arc.arc, but if so include a list clause
+
+(def positions (test seq)
+  (accum a
+    (let f (testify test)
+      (forlen i seq
+        (if (f (seq i)) (a i))))))
+
+(def lines (s)
+  (accum a
+    ((afn ((p . ps))
+       (if ps
+           (do (a (rem #\return (cut s (+ p 1) (car ps))))
+               (self ps))
+           (a (cut s (+ p 1)))))
+     (cons -1 (positions #\newline s)))))
+
+(def slices (s test)
+  (accum a
+    ((afn ((p . ps))
+       (if ps
+           (do (a (cut s (+ p 1) (car ps)))
+               (self ps))
+           (a (cut s (+ p 1)))))
+     (cons -1 (positions test s)))))
+
+; > (require (lib "uri-codec.ss" "net"))
+;> (form-urlencoded-decode "x%ce%bbx")
+;"xλx"
+
+; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4. 
+
+; Fixed for utf8 by pc.
+
+(def urldecode (s)
+ (tostring
+  (forlen i s
+    (caselet c (s i)
+      #\+ (writec #\space)
+      #\% (do (when (> (- (len s) i) 2)
+                (writeb (int (cut s (+ i 1) (+ i 3)) 16)))
+              (++ i 2))
+          (writec c)))))
+
+(def urlencode (s)
+  (tostring 
+    (each c s 
+      (writec #\%)
+      (let i (int c)
+        (if (< i 16) (writec #\0))
+        (pr (coerce i 'string 16))))))
+
+(mac litmatch (pat string (o start 0))
+  (w/uniq (gstring gstart)
+    `(with (,gstring ,string ,gstart ,start)
+       (unless (> (+ ,gstart ,(len pat)) (len ,gstring))
+         (and ,@(let acc nil
+                  (forlen i pat
+                    (push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
+                           acc))
+                  (rev acc)))))))
+
+; litmatch would be cleaner if map worked for string and integer args:
+
+;             ,@(map (fn (n c)  
+;                      `(is ,c (,gstring (+ ,gstart ,n))))
+;                    (len pat)
+;                    pat)
+
+(mac endmatch (pat string)
+  (w/uniq (gstring glen)
+    `(withs (,gstring ,string ,glen (len ,gstring))
+       (unless (> ,(len pat) (len ,gstring))
+         (and ,@(let acc nil
+                  (forlen i pat
+                    (push `(is ,(pat (- (len pat) 1 i)) 
+                               (,gstring (- ,glen 1 ,i)))
+                           acc))
+                  (rev acc)))))))
+
+(def posmatch (pat seq (o start 0))
+  (catch
+    (if (isa pat 'fn)
+        (for i start (- (len seq) 1)
+          (when (pat (seq i)) (throw i)))
+        (for i start (- (len seq) (len pat))
+          (when (headmatch pat seq i) (throw i))))
+    nil))
+
+(def headmatch (pat seq (o start 0))
+  (let p (len pat) 
+    ((afn (i)      
+       (or (is i p) 
+           (and (is (pat i) (seq (+ i start)))
+                (self (+ i 1)))))
+     0)))
+
+(def begins (seq pat (o start 0))
+  (unless (len> pat (- (len seq) start))
+    (headmatch pat seq start)))
+
+(def subst (new old seq)
+  (let boundary (+ (- (len seq) (len old)) 1)
+    (tostring 
+      (forlen i seq
+        (if (and (< i boundary) (headmatch old seq i))
+            (do (++ i (- (len old) 1))
+                (pr new))
+            (pr (seq i)))))))
+
+(def multisubst (pairs seq)
+  (tostring 
+    (forlen i seq
+      (iflet (old new) (find [begins seq (car _) i] pairs)
+        (do (++ i (- (len old) 1))
+            (pr new))
+        (pr (seq i))))))
+
+; not a good name
+
+(def findsubseq (pat seq (o start 0))
+  (if (< (- (len seq) start) (len pat))
+       nil
+      (if (headmatch pat seq start)
+          start
+          (findsubseq pat seq (+ start 1)))))
+
+(def blank (s) (~find ~whitec s))
+
+(def nonblank (s) (unless (blank s) s))
+
+(def trim (s (o where 'both) (o test whitec))
+  (withs (f   (testify test)
+           p1 (pos ~f s))
+    (if p1
+        (cut s 
+             (if (in where 'front 'both) p1 0)
+             (when (in where 'end 'both)
+               (let i (- (len s) 1)
+                 (while (and (> i p1) (f (s i)))
+                   (-- i))
+                 (+ i 1))))
+        "")))
+
+(def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
+  (withs (comma
+          (fn (i)
+            (tostring
+              (map [apply pr (rev _)]
+                   (rev (intersperse '(#\,)
+                                     (tuples (rev (coerce (string i) 'cons))
+                                             3))))))
+          abrep
+          (let a (abs n)
+            (if (< digits 1)
+                 (comma (roundup a))
+                (exact a)
+                 (string (comma a)
+                         (when (and trail-zeros (> digits 0))
+                           (string "." (newstring digits #\0))))
+                 (withs (d (expt 10 digits)
+                         m (/ (roundup (* a d)) d)
+                         i (trunc m)
+                         r (abs (trunc (- (* m d) (* i d)))))
+                   (+ (if (is i 0) 
+                          (if (or init-zero (is r 0)) "0" "") 
+                          (comma i))
+                      (withs (rest   (string r)
+                              padded (+ (newstring (- digits (len rest)) #\0)
+                                        rest)
+                              final  (if trail-zeros
+                                         padded
+                                         (trim padded 'end [is _ #\0])))
+                        (string (unless (empty final) ".")
+                                final)))))))
+    (if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
+        (+ "-" abrep)
+        abrep)))
+        
+
+; English
+
+(def pluralize (n str)
+  (if (or (is n 1) (single n))
+      str
+      (string str "s")))
+
+(def plural (n x)
+  (string n #\  (pluralize n x)))
+
+
+; http://www.eki.ee/letter/chardata.cgi?HTML4=1
+; http://jrgraphix.net/research/unicode_blocks.php?block=1
+; http://home.tiscali.nl/t876506/utf8tbl.html
+; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
+; http://en.wikipedia.org/wiki/Utf-8
+; http://unicode.org/charts/charindex2.html

main.go

@@ -0,0 +1,54 @@
+package main
+
+import (
+  "fmt"
+  "log"
+  "strings"
+
+  "github.com/chzyer/readline"
+
+  "github.com/hellerve/argos/eval"
+  "github.com/hellerve/argos/parser"
+)
+
+func main() {
+  rl, err := readline.New("argos> ")
+
+  if err != nil {
+    log.Fatal(err)
+  }
+
+  defer rl.Close()
+
+  e := eval.ParentEnv()
+  for {
+    prompt, err := rl.Readline()
+
+    if err != nil {
+      return
+    }
+
+    parsed, err, unconsumed := parser.Parse(prompt)
+
+    if err != nil {
+      fmt.Println(err)
+      continue
+    }
+
+    if len(unconsumed) != 0 {
+      fmt.Println("Unconsumed input:", strings.Join(unconsumed, " "))
+      continue
+    }
+
+    // TODO: how to avoid bindings on error?
+    evald, err := eval.Eval(parsed, e)
+
+
+    if err != nil {
+      fmt.Println(err)
+      continue
+    }
+
+    fmt.Println(evald.Pretty())
+  }
+}

parser/parser.go

@@ -0,0 +1,103 @@
+package parser
+
+import (
+  "errors"
+  "strconv"
+  "strings"
+
+  "github.com/hellerve/argos/ast"
+)
+
+func withoutEmpty(input []string) []string {
+    var r []string
+    for _, str := range input {
+        if str != "" {
+            r = append(r, str)
+        }
+    }
+    return r
+}
+
+func tokenize(input string) []string {
+  return withoutEmpty(strings.Split(strings.Replace(strings.Replace(input, "(", " ( ", -1), ")", " ) ", -1), " "))
+}
+
+func parseValue(input []string) (*ast.AST, error, []string) {
+  var res ast.AST
+
+  f, err := strconv.ParseFloat(input[0], 64)
+
+  if err == nil {
+    res = ast.AST{ast.Num, f}
+    return &res, nil, input[1:]
+  }
+
+  if input[0][0] == '"' {
+    var agg []string
+    for {
+      if len(input) == 0 {
+        return nil, errors.New("Unmatched \""), input
+      }
+      token := input[0]
+      input = input[1:]
+      agg = append(agg, token)
+      if token[len(token)-1] == '"' {
+        break
+      }
+    }
+    res = ast.AST{ast.String, strings.Join(agg, " ")}
+    return &res, nil, input
+  }
+
+  res = ast.AST{ast.Symbol, input[0]}
+  return &res, nil, input[1:]
+}
+
+func parseToken(input []string) (*ast.AST, error, []string) {
+  if len(input) == 0 {
+    return nil, errors.New("Unmatched '('"), input
+  }
+
+  if input[0][0] == '\'' {
+    if (input[0] == "'") {
+      input = input[1:]
+    } else {
+      input = append([]string{input[0][1:]}, input[1:]...)
+    }
+    tmp, err, input := parseToken(input)
+
+    if err != nil {
+      return nil, err, input
+    }
+
+    res := ast.AST{ast.List, []ast.AST{ast.AST{ast.Symbol, "quote"}, *tmp}}
+    return &res, nil, input
+  }
+
+  switch input[0] {
+    case "(": {
+      var l []ast.AST
+      input = input[1:]
+      for input[0] != ")" {
+        elem, err, newInput := parseToken(input)
+
+        if err != nil {
+          return nil, err, input
+        }
+
+        l = append(l, *elem)
+        input = newInput
+      }
+      res := ast.AST{ast.List, l}
+      return &res, nil, input[1:]
+    }
+    case ")": {
+      return nil, errors.New("Unmatched ')'"), input
+    }
+  }
+  return parseValue(input)
+}
+
+func Parse(input string) (*ast.AST, error, []string) {
+  return parseToken(tokenize(input))
+}