Improved Emacs mode, with standard library 'keyword' table generated automatically...

diff --git a/elisp/domtool-mode-startup.el b/elisp/domtool-mode-startup.el
index 2f5013d..c00df20 100644 (file)
--- a/elisp/domtool-mode-startup.el
+++ b/elisp/domtool-mode-startup.el
@@ -1,4 +1,4 @@
 (autoload (quote domtool-mode) "domtool-mode/domtool-mode" "\
 Major Mode for editing Domtool files." t nil)
 
-(add-to-list (quote auto-mode-alist) (quote ("\\.\\(com\\|net\\|org\\|edu\\|mil\\|biz\\|info\\|name\\|be\\|ca\\|cc\\|de\\|fr\\|in\\|mu\\|se\\|uk\\|us\\|ws\\)" . domtool-mode)))
+(add-to-list (quote auto-mode-alist) (quote ("\\.\\(com\\|net\\|org\\|edu\\|mil\\|biz\\|info\\|name\\|be\\|ca\\|cc\\|de\\|fr\\|in\\|mu\\|se\\|uk\\|us\\|ws\\)$" . domtool-mode)))

diff --git a/elisp/domtool-mode.el b/elisp/domtool-mode.el
index d1a4a98..3f8d193 100644 (file)
--- a/elisp/domtool-mode.el
+++ b/elisp/domtool-mode.el
@@ -37,16 +37,43 @@
        ))
     table))
 
+(defun domtool-syms-re (&rest syms)
+  (concat "\\<" (regexp-opt syms t) "\\>"))
+
+(defconst domtool-types-regexp
+  (domtool-syms-re "proxy_target" "proxy_port" "mod_rewrite_cond_flag" "mod_rewrite_flag" "rewrite_arg" "redirect_code" "autoindex_option" "autoindex_width" "homedir_path" "dnsRecord" "apache_option" "authType" "location" "ssl" "ssl_cert_path" "suexec_flag" "web_node" "aliasTarget" "aliasSource" "email" "emailUser" "mail_node" "dnsKind" "master" "dns_node" "soa" "serial" "your_path" "your_group" "your_user" "group" "user" "node" "your_domain_host" "your_domain" "domain" "host" "ip" "no_newlines" "no_spaces" "bool" "string" "int")
+  "A regexp that matches Domtool types from the standard library.")
+
+(defconst domtool-contexts-regexp
+  (domtool-syms-re "Location" "Vhost" "Domain")
+  "A regexp that matches Domtool contexts from the standard library.")
+
+(defconst domtool-actions-regexp
+  (domtool-syms-re "errorDocument" "scriptAlias" "alias" "proxyPassReverse" "proxyPass" "rewriteLogLevel" "localProxyRewrite" "rewriteBase" "rewriteCond" "rewriteRule" "setEnv" "davFilesystem" "readmeName" "headerName" "unset_indexOptions" "set_indexOptions" "indexOptions" "addDescription" "mailmanWebHost" "dnsDefault" "dnsAlias" "dnsMail" "dnsIP" "nameserver" "dom" "web" "webAt" "relayMail" "handleMail" "dns" "addDefaultCharset" "action" "forceTypeOff" "forceType" "directoryIndex" "unset_options" "set_options" "options" "satisfyAny" "satisfyAll" "denyFrom" "denyFromAll" "allowFrom" "allowFromAll" "orderDenyAllow" "orderAllowDeny" "requireGroup" "requireUser" "requireValidUser" "authUserFile" "authName" "authType" "serverAliasDefault" "serverAlias" "serverAliasHost" "directory" "location" "vhost" "defaultAlias" "aliasDrop" "aliasMulti" "emailAlias" "aliasPrim" "domain")
+  "A regexp that matches Domtool actions from the standard library.")
+
+(defconst domtool-vals-regexp
+  (domtool-syms-re "ornext" "cond_nocase" "env" "skip" "redirectWith" "mimeType" "passthrough" "noescape" "qsappend" "nocase" "nosubreq" "chain" "last" "gone" "forbidden" "redirect" "redir307" "redir305" "redir304" "redir303" "redir302" "redir301" "redir300" "seeother" "permanent" "temp" "xhtml" "versionSort" "trackModified" "suppressSize" "suppressRules" "suppressLastModified" "suppressIcon" "suppressHtmlPreamble" "suppressDescription" "suppressColumnSorting" "scanHtmlTitles" "nameWidth" "ignoreClient" "ignoreCase" "iconWidth" "iconHeight" "iconsAreLinks" "htmlTable" "foldersFirst" "fancyIndexing" "descriptionWidth" "characters" "autofit" "home" "web_node" "default_node" "dnsDefaultA" "dnsNS" "dnsMX" "dnsCNAME" "dnsA" "indexes" "includesNOEXEC" "execCGI" "kerberos" "digest" "basic" "use_cert" "no_ssl" "web_node_to_node" "dropTarget" "addressesTarget" "addressTarget" "catchAllSource" "defaultSource" "userSource" "mail_node_to_node" "noDns" "useDns" "internalMaster" "externalMaster" "dns_node_to_node" "defaultSoa" "soa" "serialConst" "serialAuto" "ip_of_node" "true" "false")
+  "A regexp that matches Domtool vals from the standard library.")
+
+(defconst domtool-env-vars-regexp
+  (domtool-syms-re "Aliases" "DNS" "DocumentRoot" "Group" "MailNodes" "Mailbox" "SSL" "ServerAdmin" "SuExec" "TTL" "User" "WebNodes")
+  "A regexp that matches Domtool env-vars from the standard library.")
+
 (defvar domtool-font-lock-keywords
   `(,(concat
       "\\_<"
       (regexp-opt '("let" "in" "begin" "end" "with" "where" "extern" "type"
-                    "val" "context" "Root"
-                    ;; Actions
-                    "vhost" "location" "directory" "domain" "dom"
-                    "webAt" "web")
+                    "val" "context" "Root")
                   t)
       "\\_>")
+
+    (,domtool-actions-regexp . font-lock-builtin-face)
+    (,domtool-vals-regexp . font-lock-variable-name-face)
+    (,domtool-contexts-regexp . font-lock-constant-face)
+    (,domtool-env-vars-regexp . font-lock-constant-face)
+    (,domtool-types-regexp . font-lock-type-face)
+
     ("type[ \t]+\\(\\(\\sw\\|\\s_\\)+\\)" 1 font-lock-type-face)
     ("val[ \t]+\\(\\(\\sw\\|\\s_\\)+\\)" 1 font-lock-variable-name-face)))
 

diff --git a/src/autodoc.sig b/src/autodoc.sig
index 8f52802..c36ee33 100644 (file)
--- a/src/autodoc.sig
+++ b/src/autodoc.sig
@@ -21,5 +21,6 @@
 signature AUTODOC = sig
 
     val autodoc : {outdir : string, infiles : string list} -> unit
+    val makeEmacsKeywords : string list -> unit
 
 end

diff --git a/src/autodoc.sml b/src/autodoc.sml
index 86c8651..640012c 100644 (file)
--- a/src/autodoc.sml
+++ b/src/autodoc.sml
@@ -1,5 +1,5 @@
 (* HCoop Domtool (http://hcoop.sourceforge.net/)
- * Copyright (c) 2006, Adam Chlipala
+ * Copyright (c) 2006-2007, Adam Chlipala
  *
  * This program is free software; you can redistribute it and/or
  * modify it under the terms of the GNU General Public License
@@ -187,4 +187,72 @@ fun autodoc {outdir, infiles} =
        app doFile infiles
     end
 
+fun makeEmacsKeywords infiles =
+    let
+       val (_, infiles) = Order.order NONE infiles
+       val G = foldl (fn (fname, G) => check' G fname) Env.empty infiles       
+
+       fun annotate_decl d =
+           case d of
+               DVal (name, NONE, e) =>
+               (case Env.lookupVal G name of
+                    NONE => d
+                  | SOME t => DVal (name, SOME t, e))
+             | _ => d
+
+       fun doFile (file, acc) =
+           let
+               val (_, decls, _) = Parse.parse file
+
+               fun isAction evs (t, _) =
+                   case t of
+                       TAction (_, r1, r2) =>
+                       let
+                           fun enrich (r, evs) =
+                               StringMap.foldli (fn (ev, _, evs) =>
+                                                    StringSet.add (evs, ev))
+                                     evs r
+                       in
+                           SOME (enrich (r2, enrich (r1, evs)))
+                       end
+                     | TArrow (_, t) => isAction evs t
+                     | TNested (_, t) => isAction evs t
+                     | TUnif (_, ref (SOME t)) => isAction evs t
+                     | _ => NONE
+           in
+               foldl (fn ((d, _, _), (types, contexts, actions, vals, evs)) =>
+                         case annotate_decl d of
+                             DExternType s => (s :: types, contexts, actions, vals, evs)
+                           | DExternVal (s, t) =>
+                             (case isAction evs t of
+                                  SOME evs => (types, contexts, s :: actions, vals, evs)
+                                | NONE => (types, contexts, actions, s :: vals, evs))
+                           | DVal (s, NONE, _) => (types, contexts, actions, s :: vals, evs)
+                           | DVal (s, SOME t, _) =>
+                             (case isAction evs t of
+                                  SOME evs => (types, contexts, s :: actions, vals, evs)
+                                | NONE => (types, contexts, actions, s :: vals, evs))
+                           | DContext s => (types, s :: contexts, actions, vals, evs))
+                     acc decls
+           end
+
+       val (types, contexts, actions, vals, evs) =
+           foldl doFile ([], [], [], [], StringSet.empty) infiles
+
+       fun printKind (ident, syms) =
+           (print "(defconst domtool-";
+            print ident;
+            print "-regexp\n  (domtool-syms-re";
+            app (fn s => (print " \""; print s; print "\"")) syms;
+            print ")\n  \"A regexp that matches Domtool ";
+            print ident;
+            print " from the standard library.\")\n\n")
+    in
+       printKind ("types", types);
+       printKind ("contexts", contexts);
+       printKind ("actions", actions);
+       printKind ("vals", vals);
+       printKind ("env-vars", StringSet.listItems evs)
+    end
+
 end

diff --git a/src/main-doc.sml b/src/main-doc.sml
index 3df2ad3..f088f8b 100644 (file)
--- a/src/main-doc.sml
+++ b/src/main-doc.sml
@@ -1,5 +1,5 @@
 (* HCoop Domtool (http://hcoop.sourceforge.net/)
- * Copyright (c) 2006, Adam Chlipala
+ * Copyright (c) 2006-2007, Adam Chlipala
  *
  * This program is free software; you can redistribute it and/or
  * modify it under the terms of the GNU General Public License
@@ -18,19 +18,25 @@
 
 (* Driver for documentation generation *)
 
-fun processArgs (args, basis, outdir, files) =
+fun processArgs (args, basis, outdir, files, emacs) =
     case args of
-       [] => (basis, outdir, files)
-      | "-basis" :: rest => processArgs (rest, true, outdir, files)
-      | "-out" :: dir :: rest => processArgs (rest, basis, dir, files)
-      | file :: rest => processArgs (rest, basis, outdir, file :: files)
+       [] => (basis, outdir, files, emacs)
+      | "-basis" :: rest => processArgs (rest, true, outdir, files, emacs)
+      | "-out" :: dir :: rest => processArgs (rest, basis, dir, files, emacs)
+      | "-emacs" :: rest => processArgs (rest, basis, outdir, files, true)
+      | file :: rest =>
+       if size file > 0 andalso String.sub (file, 0) <> #"-" then
+           processArgs (rest, basis, outdir, file :: files, emacs)
+       else
+           raise Fail ("Uknown switch " ^ file)
 
 val _ =
     let
-       val (basis, outdir, files) = processArgs (CommandLine.arguments (),
-                                                 false,
-                                                 OS.FileSys.getDir (),
-                                                 [])
+       val (basis, outdir, files, emacs) = processArgs (CommandLine.arguments (),
+                                                        false,
+                                                        OS.FileSys.getDir (),
+                                                        [],
+                                                        false)
 
        val files = if basis then
                        Main.listBasis () @ files
@@ -38,5 +44,8 @@ val _ =
                        files
     in
        Tycheck.allowExterns ();
-       Autodoc.autodoc {outdir = outdir, infiles = files}
+       if emacs then
+           Autodoc.makeEmacsKeywords files
+       else
+           Autodoc.autodoc {outdir = outdir, infiles = files}
     end