src/compiler.sml

(*
 * Dynamic web page generation with Standard ML
 * Copyright (C) 2003  Adam Chlipala
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)

(* Template compiler interface *)

structure Compiler :> COMPILER =
struct
    exception Error

    val cgiMode = Posix.FileSys.S.flags [Posix.FileSys.S.irwxu,
					 Posix.FileSys.S.iroth,
					 Posix.FileSys.S.ixoth]

    val consumer = {consumer = TextIO.print,
		    flush = fn () => TextIO.flushOut TextIO.stdOut,
		    linewidth = 80}

    fun getFname path =
	let
	    fun look i =
		if i < 0 then
		    path
		else if String.sub (path, i) = #"/" then
		    String.extract (path, i+1, NONE)
		else
		    look (i-1)
	in
	    look (size path - 1)
	end

    fun removeExt path =
	let
	    val len = size path

	    fun look i =
		if i >= len then
		    path
		else if String.sub (path, i) = #"." then
		    String.substring (path, 0, i)
		else
		    look (i+1)
	in
	    look 0
	end

    fun getExt path =
	let
	    val len = size path

	    fun look i =
		if i >= len then
		    path
		else if String.sub (path, i) = #"." then
		    String.extract (path, i+1, NONE)
		else
		    look (i+1)
	in
	    look 0
	end

    val upperOffset = ord #"A" - ord #"a"
    fun toUpper ch =
	if Char.isLower ch then
	    chr (ord ch + upperOffset)
	else
	    ch

    fun makeName name =
	let
	    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

    fun compileDirectory config =
	let
	    val path = Config.inPath config
	    val outPath = Config.outPath config
	    val sml = Config.sml config

	    val dir = Posix.FileSys.opendir path

	    fun loop (smls, mlts) =
		(case Posix.FileSys.readdir dir of
		     NONE => (smls, mlts)
		   | SOME fname =>
		     (case getExt fname of
			  "mlt" => loop (smls, (path ^ "/" ^ fname) :: mlts)
			| ("sml"|"sig") =>
			  let
			      val fname = getFname fname
			  in
			      if String.sub (fname, 0) = #"_" then
				  loop (smls, mlts)
			      else
				  loop ((path ^ "/" ^ fname) :: smls, mlts)
			  end
			| _ => loop (smls, mlts)))

	    val (smls, mlts) = loop ([], [])

	    val outf = TextIO.openOut (outPath ^ "/libs.cm")
	    val printNames = app (fn name => TextIO.output (outf, "\t" ^ name ^ "\n"))
	    val _ = TextIO.output (outf, "Group is\n\t");
	    val _ = TextIO.output (outf, Config.lib config)
	    val _ = TextIO.output (outf, "\n")
	    val _ = TextIO.output (outf, "\n\t(* Extra libraries and such *)\n\n")
	    val _ = printNames (Config.cm config)
	    val _ = TextIO.output (outf, "\n\t(* Project SML sources *)\n\n")
	    val _ = printNames smls
	    val _ = TextIO.closeOut outf

	    val outf = TextIO.openOut (outPath ^ "/.build.sml")
	    val _ = TextIO.output (outf, "Control.quotation := true;\nControl.printWarnings := false;\n")
	    fun printMlts [] = ()
	      | printMlts (h::t) =
		(TextIO.output (outf, "\"" ^ h ^ "\"");
		 List.app (fn n => TextIO.output (outf, ", \"" ^ n ^ "\"")) t)

	    val libList = foldl (fn (l, s) => s ^ "if CM.make \"" ^ l ^ "\" then () else OS.Process.exit OS.Process.failure;\n") "" (Config.cm config)
	in
	    TextIO.output (outf, "if CM.make \"" ^ outPath ^ "/libs.cm\" then () else OS.Process.exit OS.Process.failure;\nif CM.make \"" ^ Config.compiler config ^ "\" then () else OS.Process.exit OS.Process.failure;\nif CM.make \"" ^ Config.lib config ^ "\" then () else OS.Process.exit OS.Process.failure;\n");
	    TextIO.output (outf, libList);
	    TextIO.output (outf, "Compiler.compileTemplates (Config.read \"mlt.conf\" (Config.default ())) ([");
	    printMlts mlts;
	    TextIO.output (outf, "], [");
	    printMlts smls;
	    TextIO.output (outf, "]);\n");
	    TextIO.closeOut outf;
	    OS.Process.system ("cat " ^ outPath ^ "/.build.sml | " ^ sml ^ "/sml")
	end

    fun compileTemplates config (mlts, smls) =
	let
	    val err_flag = ref false
	    val _ = ErrorMsg.reset ()

	    val path = Config.inPath config
	    val outPath = Config.outPath config
	    val pubPath = Config.pubPath config
	    val sml = Config.sml config
	    val arch = "x86-linux"

	    val loc = Environment.staticPart (#get (EnvRef.loc ()) ())
	    val base = Environment.staticPart (#get (EnvRef.base ()) ())
	    val env = StaticEnv.atop (base, loc)

	    (*fun penv env = (print "I know about these symbols:\n";
			    StaticEnv.app (fn (sym, _) => print (Symbol.describe sym ^ "\n")) env)

	    val _ = penv base
	    val _ = penv loc*)

	    val templates = StringSet.addList (StringSet.empty, map (getFname o removeExt) mlts)
	    val _ = print "Templates: "
	    val _ = StringSet.app (fn s => print (s ^ "; ")) templates
	    val _ = print "\n"

	    fun ct (fname, (exports, outputs, scripts)) =
		let
		    val _ = print ("Compiling " ^ fname ^ "....\n")
		    val (name, output) = compileTemplate (config, env, templates) fname
		    val _ = err_flag := (!err_flag orelse !ErrorMsg.anyErrors)
		    val scriptName = removeExt (getFname fname)
		    val outName = "__" ^ scriptName ^ ".sml"
		    val outf = TextIO.openOut (outPath ^ "/" ^ outName)
		in
		    TextIO.output (outf, output);
		    TextIO.closeOut outf;
		    (name :: exports, outName :: outputs, (pubPath ^ "/" ^ scriptName) :: scripts)
		end

	    val _ = print "Compiling templates....\n"

	    val (exports, outputs, scripts) = foldl ct ([], [], []) mlts

	    val outf = TextIO.openOut (outPath ^ "/_main.sml")

	    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)");
					 app (fn exp => TextIO.output (outf, ",\n\t\t(\"" ^ exp ^ "\", " ^ exp ^ ".exec)"))
					     rest))
	    val _ = TextIO.output (outf, "]\nend\n\nstructure Main = MainFn(Templates)\n")
	    val _ = TextIO.closeOut outf

	    val outf = TextIO.openOut (outPath ^ "/.build.sml")
	    val _ = TextIO.output (outf, "Control.printWarnings := false;\nCM.make \"sources.cm\";\nSMLofNJ.exportFn (\"" ^ outPath ^ "/heap\", Main.main);\n")
	    val _ = TextIO.closeOut outf

	    val outf = TextIO.openOut (outPath ^ "/sources.cm")
	    val printNames = app (fn name => TextIO.output (outf, "\t" ^ name ^ "\n"))

	    fun makeScript (name, str) =
		let
		    val outf = TextIO.openOut name
		in
		    TextIO.output (outf, "#!/bin/sh\n\n");
		    TextIO.output (outf, sml ^ "/sml @SMLload=" ^ outPath ^ "/heap." ^ arch ^ " " ^ str ^ " $*\n");
		    TextIO.closeOut outf;
		    Posix.FileSys.chmod (name, cgiMode)
		end
	in
	    if !err_flag then
		(TextIO.print "Errors compiling templates.\n";
		 OS.Process.failure)
	    else
		(TextIO.output (outf, "(* Automatic generate web fun happyness *)\n\nLibrary\n\tstructure Main\nis\n\t(* Web library *)\n\t");
		 TextIO.output (outf, Config.lib config);
		 TextIO.output (outf, "\n\n\t(* Libraries *)\n\n");
		 printNames (Config.cm config);
		 TextIO.output (outf, "\n\t(* SML sources *)\n\n");
		 printNames smls;
		 TextIO.output (outf, "\n\t(* Templates *)\n\n");
		 printNames outputs;
		 TextIO.output (outf, "\n\t(* Driver *)\n\n\t_main.sml\n");
		 TextIO.closeOut outf;
		 if OS.Process.system ("cat " ^ outPath ^ "/.build.sml | " ^ sml ^ "/sml") = OS.Process.success then
		     (ListPair.app makeScript (scripts, exports);
		      OS.Process.success)
		 else
		     OS.Process.failure)
	end
end
Commit	Line	Data
	1	(*
	2	* Dynamic web page generation with Standard ML
	3	* Copyright (C) 2003 Adam Chlipala
	4	*
	5	* This library is free software; you can redistribute it and/or
	6	* modify it under the terms of the GNU Lesser General Public
	7	* License as published by the Free Software Foundation; either
	8	* version 2.1 of the License, or (at your option) any later version.
	9	*
	10	* This library is distributed in the hope that it will be useful,
	11	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	* Lesser General Public License for more details.
	14	*
	15	* You should have received a copy of the GNU Lesser General Public
	16	* License along with this library; if not, write to the Free Software
	17	* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	18	*)
	19
	20	(* Template compiler interface *)
	21
	22	structure Compiler :> COMPILER =
	23	struct
	24	exception Error
	25
	26	val cgiMode = Posix.FileSys.S.flags [Posix.FileSys.S.irwxu,
	27	Posix.FileSys.S.iroth,
	28	Posix.FileSys.S.ixoth]
	29
	30	val consumer = {consumer = TextIO.print,
	31	flush = fn () => TextIO.flushOut TextIO.stdOut,
	32	linewidth = 80}
	33
	34	fun getFname path =
	35	let
	36	fun look i =
	37	if i < 0 then
	38	path
	39	else if String.sub (path, i) = #"/" then
	40	String.extract (path, i+1, NONE)
	41	else
	42	look (i-1)
	43	in
	44	look (size path - 1)
	45	end
	46
	47	fun removeExt path =
	48	let
	49	val len = size path
	50
	51	fun look i =
	52	if i >= len then
	53	path
	54	else if String.sub (path, i) = #"." then
	55	String.substring (path, 0, i)
	56	else
	57	look (i+1)
	58	in
	59	look 0
	60	end
	61
	62	fun getExt path =
	63	let
	64	val len = size path
	65
	66	fun look i =
	67	if i >= len then
	68	path
	69	else if String.sub (path, i) = #"." then
	70	String.extract (path, i+1, NONE)
	71	else
	72	look (i+1)
	73	in
	74	look 0
	75	end
	76
	77	val upperOffset = ord #"A" - ord #"a"
	78	fun toUpper ch =
	79	if Char.isLower ch then
	80	chr (ord ch + upperOffset)
	81	else
	82	ch
	83
	84	fun makeName name =
	85	let
	86	val name =
	87	if size name >= 1 then
	88	str (toUpper (String.sub (name, 0))) ^ String.extract (name, 1, NONE)
	89	else
	90	raise Error
	91	val name = name ^ "_"
	92	in
	93	name
	94	end
	95
	96	fun compileTemplate (config, env, templates) path =
	97	let
	98	val fname = getFname path
	99	val name = removeExt fname
	100	val name = makeName name
	101	in
	102	(name, Mlt.trans (config, env, templates, name, Parse.parse path))
	103	end
	104
	105	fun compileDirectory config =
	106	let
	107	val path = Config.inPath config
	108	val outPath = Config.outPath config
	109	val sml = Config.sml config
	110
	111	val dir = Posix.FileSys.opendir path
	112
	113	fun loop (smls, mlts) =
	114	(case Posix.FileSys.readdir dir of
	115	NONE => (smls, mlts)
	116	\| SOME fname =>
	117	(case getExt fname of
	118	"mlt" => loop (smls, (path ^ "/" ^ fname) :: mlts)
	119	\| ("sml"\|"sig") =>
	120	let
	121	val fname = getFname fname
	122	in
	123	if String.sub (fname, 0) = #"_" then
	124	loop (smls, mlts)
	125	else
	126	loop ((path ^ "/" ^ fname) :: smls, mlts)
	127	end
	128	\| _ => loop (smls, mlts)))
	129
	130	val (smls, mlts) = loop ([], [])
	131
	132	val outf = TextIO.openOut (outPath ^ "/libs.cm")
	133	val printNames = app (fn name => TextIO.output (outf, "\t" ^ name ^ "\n"))
	134	val _ = TextIO.output (outf, "Group is\n\t");
	135	val _ = TextIO.output (outf, Config.lib config)
	136	val _ = TextIO.output (outf, "\n")
	137	val _ = TextIO.output (outf, "\n\t(* Extra libraries and such *)\n\n")
	138	val _ = printNames (Config.cm config)
	139	val _ = TextIO.output (outf, "\n\t(* Project SML sources *)\n\n")
	140	val _ = printNames smls
	141	val _ = TextIO.closeOut outf
	142
	143	val outf = TextIO.openOut (outPath ^ "/.build.sml")
	144	val _ = TextIO.output (outf, "Control.quotation := true;\nControl.printWarnings := false;\n")
	145	fun printMlts [] = ()
	146	\| printMlts (h::t) =
	147	(TextIO.output (outf, "\"" ^ h ^ "\"");
	148	List.app (fn n => TextIO.output (outf, ", \"" ^ n ^ "\"")) t)
	149
	150	val libList = foldl (fn (l, s) => s ^ "if CM.make \"" ^ l ^ "\" then () else OS.Process.exit OS.Process.failure;\n") "" (Config.cm config)
	151	in
	152	TextIO.output (outf, "if CM.make \"" ^ outPath ^ "/libs.cm\" then () else OS.Process.exit OS.Process.failure;\nif CM.make \"" ^ Config.compiler config ^ "\" then () else OS.Process.exit OS.Process.failure;\nif CM.make \"" ^ Config.lib config ^ "\" then () else OS.Process.exit OS.Process.failure;\n");
	153	TextIO.output (outf, libList);
	154	TextIO.output (outf, "Compiler.compileTemplates (Config.read \"mlt.conf\" (Config.default ())) ([");
	155	printMlts mlts;
	156	TextIO.output (outf, "], [");
	157	printMlts smls;
	158	TextIO.output (outf, "]);\n");
	159	TextIO.closeOut outf;
	160	OS.Process.system ("cat " ^ outPath ^ "/.build.sml \| " ^ sml ^ "/sml")
	161	end
	162
	163	fun compileTemplates config (mlts, smls) =
	164	let
	165	val err_flag = ref false
	166	val _ = ErrorMsg.reset ()
	167
	168	val path = Config.inPath config
	169	val outPath = Config.outPath config
	170	val pubPath = Config.pubPath config
	171	val sml = Config.sml config
	172	val arch = "x86-linux"
	173
	174	val loc = Environment.staticPart (#get (EnvRef.loc ()) ())
	175	val base = Environment.staticPart (#get (EnvRef.base ()) ())
	176	val env = StaticEnv.atop (base, loc)
	177
	178	(*fun penv env = (print "I know about these symbols:\n";
	179	StaticEnv.app (fn (sym, _) => print (Symbol.describe sym ^ "\n")) env)
	180
	181	val _ = penv base
	182	val _ = penv loc*)
	183
	184	val templates = StringSet.addList (StringSet.empty, map (getFname o removeExt) mlts)
	185	val _ = print "Templates: "
	186	val _ = StringSet.app (fn s => print (s ^ "; ")) templates
	187	val _ = print "\n"
	188
	189	fun ct (fname, (exports, outputs, scripts)) =
	190	let
	191	val _ = print ("Compiling " ^ fname ^ "....\n")
	192	val (name, output) = compileTemplate (config, env, templates) fname
	193	val _ = err_flag := (!err_flag orelse !ErrorMsg.anyErrors)
	194	val scriptName = removeExt (getFname fname)
	195	val outName = "__" ^ scriptName ^ ".sml"
	196	val outf = TextIO.openOut (outPath ^ "/" ^ outName)
	197	in
	198	TextIO.output (outf, output);
	199	TextIO.closeOut outf;
	200	(name :: exports, outName :: outputs, (pubPath ^ "/" ^ scriptName) :: scripts)
	201	end
	202
	203	val _ = print "Compiling templates....\n"
	204
	205	val (exports, outputs, scripts) = foldl ct ([], [], []) mlts
	206
	207	val outf = TextIO.openOut (outPath ^ "/_main.sml")
	208
	209	fun isTemplate x =
	210	let
	211	val x = makeName x
	212	in
	213	if List.exists (fn y => x = y) exports then
	214	SOME x
	215	else
	216	NONE
	217	end
	218	fun decide NONE = "(fn () => ())"
	219	\| decide (SOME t) =
	220	(case isTemplate t of
	221	SOME t => t ^ ".exec"
	222	\| _ => (err_flag := true;
	223	print ("Template " ^ t ^ " specified in mlt.conf does not exist!\n");
	224	"(fn () => ())"))
	225	val beforeT = decide (Config.beforeT config)
	226	val afterT = decide (Config.afterT config)
	227	val exnT = decide (Config.exnT config)
	228
	229	val _ = (TextIO.output (outf, "structure Templates :> TEMPLATES =\nstruct\n\tval beforeFn =");
	230	TextIO.output (outf, beforeT);
	231	TextIO.output (outf, "\n\tval afterFn = ");
	232	TextIO.output (outf, afterT);
	233	TextIO.output (outf, "\n\tval exnFn = ");
	234	TextIO.output (outf, exnT);
	235	TextIO.output (outf, "\n\n\tval templates = ["))
	236	val _ = (case exports of
	237	[] => ()
	238	\| (exp::rest) => (TextIO.output (outf, "(\"" ^ exp ^ "\", " ^ exp ^ ".exec)");
	239	app (fn exp => TextIO.output (outf, ",\n\t\t(\"" ^ exp ^ "\", " ^ exp ^ ".exec)"))
	240	rest))
	241	val _ = TextIO.output (outf, "]\nend\n\nstructure Main = MainFn(Templates)\n")
	242	val _ = TextIO.closeOut outf
	243
	244	val outf = TextIO.openOut (outPath ^ "/.build.sml")
	245	val _ = TextIO.output (outf, "Control.printWarnings := false;\nCM.make \"sources.cm\";\nSMLofNJ.exportFn (\"" ^ outPath ^ "/heap\", Main.main);\n")
	246	val _ = TextIO.closeOut outf
	247
	248	val outf = TextIO.openOut (outPath ^ "/sources.cm")
	249	val printNames = app (fn name => TextIO.output (outf, "\t" ^ name ^ "\n"))
	250
	251	fun makeScript (name, str) =
	252	let
	253	val outf = TextIO.openOut name
	254	in
	255	TextIO.output (outf, "#!/bin/sh\n\n");
	256	TextIO.output (outf, sml ^ "/sml @SMLload=" ^ outPath ^ "/heap." ^ arch ^ " " ^ str ^ " $*\n");
	257	TextIO.closeOut outf;
	258	Posix.FileSys.chmod (name, cgiMode)
	259	end
	260	in
	261	if !err_flag then
	262	(TextIO.print "Errors compiling templates.\n";
	263	OS.Process.failure)
	264	else
	265	(TextIO.output (outf, "(* Automatic generate web fun happyness )\n\nLibrary\n\tstructure Main\nis\n\t( Web library *)\n\t");
	266	TextIO.output (outf, Config.lib config);
	267	TextIO.output (outf, "\n\n\t(* Libraries *)\n\n");
	268	printNames (Config.cm config);
	269	TextIO.output (outf, "\n\t(* SML sources *)\n\n");
	270	printNames smls;
	271	TextIO.output (outf, "\n\t(* Templates *)\n\n");
	272	printNames outputs;
	273	TextIO.output (outf, "\n\t(* Driver *)\n\n\t_main.sml\n");
	274	TextIO.closeOut outf;
	275	if OS.Process.system ("cat " ^ outPath ^ "/.build.sml \| " ^ sml ^ "/sml") = OS.Process.success then
	276	(ListPair.app makeScript (scripts, exports);
	277	OS.Process.success)
	278	else
	279	OS.Process.failure)
	280	end
	281	end