From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 10 Aug 2003 16:56:30 +0000 (+0000)
Subject: Add before, after, and exn config directives
X-Git-Url: http://git.hcoop.net/bpt/mlt.git/commitdiff_plain/b26ce3d96429d8721e85500d48d7dab2f97688e5

Add before, after, and exn config directives
---

diff --git a/doc/manual.tex b/doc/manual.tex
index beb35d5..ada1809 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -48,6 +48,12 @@ Files consist of a sequence of the following kinds of lines in any order:
 	\item {\tt cm {\it file}}: {\it file} is the path to a file that the SML/NJ Compilation Manager understands (i.e., {\tt .cm}, {\tt .sml}, {\tt .sig}, {\tt .grm}, {\tt .lex}). This file is to be made available to templates in the project.
 
 	\item {\tt print {\it type} = {\it code}}: This declares that the given {\it code} is an SML expression that evaluates to an appropriate function for printing values of the SML {\it type}. The {\it code} should usually be the name of a function defined in a library or project SML source file.
+
+	\item {\tt before {\it template}}: Run {\it template} before every normally-requested template, including its output at the beginning of the final output. This can be used to set up project-wide global state. Performing initialization inside project SML files will not generally be good enough. This is because all of the structure definitions these contain are evaluated at ``compile time,'' causing their code not found inside function definitions to be run only once.
+
+	\item {\tt after {\it template}}: Run {\it template} after every successfully executing template, including its output at the end.
+
+	\item {\tt exn {\it template}}: Run {\it template} when an exception goes uncaught during normal template execution. The function {\tt Web.getExn : unit -> exn} can be used to retrieve the causing exception from within {\it template}. The {\tt before} and {\tt after} templates are not run in the {\tt exn} template when it is executed because of an uncaught exception.
 \end{itemize}
 
 \section{The template language}
diff --git a/src/compiler.sml b/src/compiler.sml
index e87cb57..0b6d484 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -81,16 +81,23 @@ struct
 	else
 	    ch
 
-    fun compileTemplate (config, env, templates) path =
+    fun makeName name = 
 	let
-	    val fname = getFname path
-	    val name = removeExt fname
 	    val name =
 		if size name >= 1 then
 		    str (toUpper (String.sub (name, 0))) ^ String.extract (name, 1, NONE)
 		else
 		    raise Error
 	    val name = name ^ "_"
+	in
+	    name
+	end
+
+    fun compileTemplate (config, env, templates) path =
+	let
+	    val fname = getFname path
+	    val name = removeExt fname
+	    val name = makeName name
 	in
 	    (name, Mlt.trans (config, env, templates, name, Parse.parse path))
 	end
@@ -199,7 +206,33 @@ struct
 
 	    val outf = TextIO.openOut (outPath ^ "/_main.sml")
 
-	    val _ = TextIO.output (outf, "structure Templates :> TEMPLATES =\nstruct\n\tval templates = [")
+	    fun isTemplate x =
+		let
+		    val x = makeName x
+		in
+		    if List.exists (fn y => x = y) exports then
+			SOME x
+		    else
+			NONE
+		end
+	    fun decide NONE = "(fn () => ())"
+	      | decide (SOME t) =
+		(case isTemplate t of
+		     SOME t => t ^ ".exec"
+		   | _ => (err_flag := true;
+			   print ("Template " ^ t ^ " specified in mlt.conf does not exist!\n");
+			   "(fn () => ())"))
+	    val beforeT = decide (Config.beforeT config)
+	    val afterT = decide (Config.afterT config)
+	    val exnT = decide (Config.exnT config)
+
+	    val _ = (TextIO.output (outf, "structure Templates :> TEMPLATES =\nstruct\n\tval beforeFn =");
+		     TextIO.output (outf, beforeT);
+		     TextIO.output (outf, "\n\tval afterFn = ");
+		     TextIO.output (outf, afterT);
+		     TextIO.output (outf, "\n\tval exnFn = ");
+		     TextIO.output (outf, exnT);
+		     TextIO.output (outf, "\n\n\tval templates = ["))
 	    val _ = (case exports of
 			 [] => ()
 		       | (exp::rest) => (TextIO.output (outf, "(\"" ^ exp ^ "\", " ^ exp ^ ".exec)");
diff --git a/src/config.sig b/src/config.sig
index 57c0f86..e8e49bb 100644
--- a/src/config.sig
+++ b/src/config.sig
@@ -33,6 +33,9 @@ sig
     val compiler : config -> string
     val cm : config -> string list
     val sml : config -> string
+    val beforeT : config -> string option
+    val afterT : config -> string option
+    val exnT : config -> string option
 
     val printFn : config -> string -> string option
 end
\ No newline at end of file
diff --git a/src/config.sml b/src/config.sml
index d021359..691f714 100644
--- a/src/config.sml
+++ b/src/config.sml
@@ -32,7 +32,11 @@ struct
  		        sml : string, (* Path to sml program *)
                         printFn : string StringMap.map, (* Map from SML type names to text for functions to print
 							 * their values *)
-		        cm : string list (* List of extra SML/CM files to use with this project *)}
+		        cm : string list, (* List of extra SML/CM files to use with this project *)
+		        beforeT : string option, (* Template to run before every template execution *)
+		        afterT : string option, (* Template to run after every successful template execution *)
+		        exnT : string option (* Template to run after every template execution
+					      * ending in an uncaught exception *)}
 
     fun inPath (CONFIG {inPath, ...}) = inPath
     fun outPath (CONFIG {outPath, ...}) = outPath
@@ -40,6 +44,9 @@ struct
     fun lib (CONFIG {lib, ...}) = lib
     fun sml (CONFIG {sml, ...}) = sml
     fun compiler (CONFIG {compiler, ...}) = compiler
+    fun beforeT (CONFIG {beforeT, ...}) = beforeT
+    fun afterT (CONFIG {afterT, ...}) = afterT
+    fun exnT (CONFIG {exnT, ...}) = exnT
     fun cm (CONFIG {cm, ...}) = cm
     fun printFn (CONFIG {printFn, ...}) s = StringMap.find (printFn, s)
 
@@ -53,7 +60,7 @@ struct
 	let
 	    val inf = TextIO.openIn fname
 
-	    fun read (fields as {inPath, outPath, pubPath, lib, compiler, cm, sml, printFn}) =
+	    fun read (fields as {inPath, outPath, pubPath, lib, compiler, cm, sml, printFn, beforeT, afterT, exnT}) =
 		(case TextIO.inputLine inf of
 		     "" => CONFIG fields
 		   | line =>
@@ -61,22 +68,40 @@ struct
 			  [] => read fields
 			| ["in", inPath] => read {inPath = expandPath inPath, outPath = outPath, pubPath = pubPath,
 						  lib = lib, compiler = compiler, printFn = printFn,
-						  cm = cm, sml = sml}
+						  cm = cm, sml = sml,
+						  beforeT = beforeT, afterT = afterT, exnT = exnT}
 			| ["out", outPath] => read {inPath = inPath, outPath = expandPath outPath, pubPath = pubPath,
 						    lib = lib, compiler = compiler, printFn = printFn,
-						    cm = cm, sml = sml}
+						    cm = cm, sml = sml,
+						    beforeT = beforeT, afterT = afterT, exnT = exnT}
 			| ["pub", pubPath] => read {inPath = inPath, outPath = outPath, pubPath = expandPath pubPath,
 						    lib = lib, compiler = compiler, printFn = printFn,
-						    cm = cm, sml = sml}
+						    cm = cm, sml = sml,
+						    beforeT = beforeT, afterT = afterT, exnT = exnT}
 			| ["lib", lib] => read {inPath = inPath, outPath = outPath, pubPath = pubPath,
 						lib = lib, compiler = compiler, printFn = printFn,
-						cm = cm, sml = sml}
+						cm = cm, sml = sml,
+						beforeT = beforeT, afterT = afterT, exnT = exnT}
 			| ["compiler", compiler] => read {inPath = inPath, outPath = outPath, pubPath = pubPath,
 							  lib = lib, compiler = compiler, printFn = printFn,
-							  cm = cm, sml = sml}
+							  cm = cm, sml = sml,
+							  beforeT = beforeT, afterT = afterT, exnT = exnT}
 			| ["sml", sml] => read {inPath = inPath, outPath = outPath, pubPath = pubPath,
 						lib = lib, compiler = compiler, printFn = printFn,
-						cm = cm, sml = sml}
+						cm = cm, sml = sml,
+						beforeT = beforeT, afterT = afterT, exnT = exnT}
+			| ["before", beforeT] => read {inPath = inPath, outPath = expandPath outPath, pubPath = pubPath,
+						       lib = lib, compiler = compiler, printFn = printFn,
+						       cm = cm, sml = sml,
+						       beforeT = SOME beforeT, afterT = afterT, exnT = exnT}
+			| ["after", afterT] => read {inPath = inPath, outPath = outPath, pubPath = expandPath pubPath,
+						     lib = lib, compiler = compiler, printFn = printFn,
+						     cm = cm, sml = sml,
+						     beforeT = beforeT, afterT = SOME afterT, exnT = exnT}
+			| ["exn", exnT] => read {inPath = inPath, outPath = outPath, pubPath = pubPath,
+						 lib = lib, compiler = compiler, printFn = printFn,
+						 cm = cm, sml = sml,
+						 beforeT = beforeT, afterT = afterT, exnT = SOME exnT}
 			| "print"::rest =>
 			  let
 			      fun split ([], _) = (print "Bad printFn directive\n";
@@ -90,7 +115,8 @@ struct
 				  in
 				      read {inPath = inPath, outPath = outPath, pubPath = pubPath,
 					    lib = lib, compiler = compiler, printFn = printFn,
-					    cm = cm, sml = sml}
+					    cm = cm, sml = sml,
+					    beforeT = beforeT, afterT = afterT, exnT = exnT}
 				  end
 				| split (h::after, befor) = split (after, h::befor)
 			  in
@@ -98,7 +124,8 @@ struct
 			  end
 			| ["cm", fname] => read {inPath = inPath, outPath = outPath, pubPath = pubPath,
 						 lib = lib, compiler = compiler, printFn = printFn,
-						 cm = fname::cm, sml = sml}
+						 cm = fname::cm, sml = sml,
+						 beforeT = beforeT, afterT = afterT, exnT = exnT}
 			| _ => (print "Unknown config directive\n";
 				read fields)))
 	in
@@ -111,13 +138,16 @@ struct
 	    val cwd = OS.FileSys.getDir ()
 	
 	    val base = CONFIG {lib = "/usr/local/share/mlt/src/lib/sources.cm",
-		    compiler = "/usr/local/share/mlt/src/sources.cm",
-		    sml = "/usr/local/sml/bin",
-		    inPath = cwd,
-		    outPath = cwd,
-		    pubPath = cwd,
-		    printFn = StringMap.empty,
-		    cm = []}
+			       compiler = "/usr/local/share/mlt/src/sources.cm",
+			       sml = "/usr/local/sml/bin",
+			       inPath = cwd,
+			       outPath = cwd,
+			       pubPath = cwd,
+			       printFn = StringMap.empty,
+			       cm = [],
+			       beforeT = NONE,
+			       afterT = NONE,
+			       exnT = NONE}
 	in
 	    read defaultFile base
 	end
diff --git a/src/lib/main.sml b/src/lib/main.sml
index b058cce..157afaa 100644
--- a/src/lib/main.sml
+++ b/src/lib/main.sml
@@ -30,6 +30,7 @@ struct
 	    fun mapper name = (name, Cgi.cgi_field_strings name)
 	in
 	    Web.pushParams (map mapper cgiFields);
+	    Templates.beforeFn ();
 	    case args of
 		[] => (print "Status: 500\nContent-type: text/html\n\n<html><head><title>500 error</title></head><body><h2>500 error</h2>No template was specified</body></html>\n";
 		       OS.Process.failure)
@@ -38,12 +39,16 @@ struct
 		     NONE => (print "Status: 404\nContent-type: text/html\n\n<html><head><title>404 error</title></head><body><h2>404 error</h2>Template not found</body></html>\n";
 			      OS.Process.failure)
 		   | SOME f => (f ();
+				Templates.afterFn ();
 				Web.output ();
 				OS.Process.success))
-	end handle Fail msg => (print "Status: 500\nContent-type: text/plain\n\nFatal error: \n\n";
-				print msg;
-				OS.Process.failure)
-		 | ex => (print "Status: 500\nContent-type: text/plain\n\nAn exception!\n\n";
-			  app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory ex);
+	end handle ex => (Web.setExn ex;
+			  Web.clear ();
+			  Templates.exnFn ();
+			  if Web.noOutput () then
+			      (print "Status: 500\nContent-type: text/plain\n\nAn exception!\n\n";
+			       app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory ex))
+			  else
+			      Web.output ();
 			  OS.Process.failure)
 end
\ No newline at end of file
diff --git a/src/lib/templates.sig b/src/lib/templates.sig
index 54650ae..bb5137c 100644
--- a/src/lib/templates.sig
+++ b/src/lib/templates.sig
@@ -22,4 +22,8 @@
 signature TEMPLATES =
 sig
     val templates : (string * (unit -> unit)) list
+
+    val beforeFn : unit -> unit
+    val afterFn : unit -> unit
+    val exnFn : unit -> unit
 end
\ No newline at end of file
diff --git a/src/lib/web.sig b/src/lib/web.sig
index 1b1e690..b6b9830 100644
--- a/src/lib/web.sig
+++ b/src/lib/web.sig
@@ -24,6 +24,8 @@ sig
     val for : (int -> unit) -> int * int -> unit
 
     val print : string -> unit
+    val clear : unit -> unit
+    val noOutput : unit -> bool
     val output : unit -> unit
 
     val setParam : string * string list -> unit
@@ -45,4 +47,7 @@ sig
     val stor : string -> real
 
     val summary : unit -> string
+
+    val getExn : unit -> exn
+    val setExn : exn -> unit
 end
\ No newline at end of file
diff --git a/src/lib/web.sml b/src/lib/web.sml
index 6d81d5b..a446e62 100644
--- a/src/lib/web.sml
+++ b/src/lib/web.sml
@@ -81,7 +81,8 @@ struct
     val text = ref ([] : string list)
 
     fun print x = text := x :: (!text)
-
+    fun clear () = text := []
+    fun noOutput () = !text = []
     fun output () =
 	(TextIO.print "Status: 200\nContent-type: text/html\n\n";
 	 TextIO.print (String.concat (List.rev (!text))))
@@ -128,4 +129,8 @@ struct
     fun summary () =
 	StringMap.foldli (fn (n, vs, s) => foldl (fn (v, s) => s ^ " VALUE: " ^ v) (s ^ " NAME: " ^ n) vs)
 	"" (!params)
+
+    val exn = ref (NONE : exn option)
+    fun setExn ex = exn := SOME ex
+    fun getExn () = valOf (!exn)
 end
\ No newline at end of file