[bpt/mlt.git] / 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
    open Settings

    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}

    val getFname = OS.Path.file

    val removeExt = OS.Path.base

    fun getExt path =
	case OS.Path.ext path of
	    NONE => path
	  | SOME ext => ext

    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 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;\nprint \"Here we go\"\n;\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 ("cd " ^ outPath ^ " ; cat .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
c0a3b488 AC	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
dc3b1a7f AC	24	open Settings
dc3b1a7f AC	25
c0a3b488 AC	26	exception Error
	27
	28	val cgiMode = Posix.FileSys.S.flags [Posix.FileSys.S.irwxu,
	29	Posix.FileSys.S.iroth,
	30	Posix.FileSys.S.ixoth]
	31
	32	val consumer = {consumer = TextIO.print,
	33	flush = fn () => TextIO.flushOut TextIO.stdOut,
	34	linewidth = 80}
	35
dcc38e49	36	val getFname = OS.Path.file
c0a3b488	37
dcc38e49	38	val removeExt = OS.Path.base
c0a3b488 AC	39
c0a3b488 AC	40	fun getExt path =
dcc38e49 AC	41	case OS.Path.ext path of
	42	NONE => path
	43	\| SOME ext => ext
c0a3b488 AC	44
	45	val upperOffset = ord #"A" - ord #"a"
	46	fun toUpper ch =
	47	if Char.isLower ch then
	48	chr (ord ch + upperOffset)
	49	else
	50	ch
	51
b26ce3d9	52	fun makeName name =
c0a3b488	53	let
c0a3b488 AC	54	val name =
	55	if size name >= 1 then
	56	str (toUpper (String.sub (name, 0))) ^ String.extract (name, 1, NONE)
	57	else
	58	raise Error
8291a2b9	59	val name = name ^ "_"
b26ce3d9 AC	60	in
	61	name
	62	end
	63
	64	fun compileTemplate (config, env, templates) path =
	65	let
	66	val fname = getFname path
	67	val name = removeExt fname
	68	val name = makeName name
c0a3b488 AC	69	in
	70	(name, Mlt.trans (config, env, templates, name, Parse.parse path))
	71	end
	72
	73	fun compileDirectory config =
	74	let
	75	val path = Config.inPath config
	76	val outPath = Config.outPath config
	77	val sml = Config.sml config
	78
	79	val dir = Posix.FileSys.opendir path
	80
	81	fun loop (smls, mlts) =
	82	(case Posix.FileSys.readdir dir of
dca24e57 AC	83	NONE => (smls, mlts)
dca24e57 AC	84	\| SOME fname =>
c0a3b488 AC	85	(case getExt fname of
	86	"mlt" => loop (smls, (path ^ "/" ^ fname) :: mlts)
	87	\| ("sml"\|"sig") =>
	88	let
8291a2b9	89	val fname = getFname fname
c0a3b488	90	in
8291a2b9	91	if String.sub (fname, 0) = #"_" then
c0a3b488 AC	92	loop (smls, mlts)
	93	else
	94	loop ((path ^ "/" ^ fname) :: smls, mlts)
	95	end
	96	\| _ => loop (smls, mlts)))
	97
	98	val (smls, mlts) = loop ([], [])
	99
	100	val outf = TextIO.openOut (outPath ^ "/libs.cm")
	101	val printNames = app (fn name => TextIO.output (outf, "\t" ^ name ^ "\n"))
	102	val _ = TextIO.output (outf, "Group is\n\t");
	103	val _ = TextIO.output (outf, Config.lib config)
	104	val _ = TextIO.output (outf, "\n")
	105	val _ = TextIO.output (outf, "\n\t(* Extra libraries and such *)\n\n")
	106	val _ = printNames (Config.cm config)
	107	val _ = TextIO.output (outf, "\n\t(* Project SML sources *)\n\n")
	108	val _ = printNames smls
	109	val _ = TextIO.closeOut outf
	110
	111	val outf = TextIO.openOut (outPath ^ "/.build.sml")
16abb0f9	112	val _ = TextIO.output (outf, "Control.quotation := true;\nControl.printWarnings := false;\n")
c0a3b488 AC	113	fun printMlts [] = ()
	114	\| printMlts (h::t) =
	115	(TextIO.output (outf, "\"" ^ h ^ "\"");
	116	List.app (fn n => TextIO.output (outf, ", \"" ^ n ^ "\"")) t)
	117
	118	val libList = foldl (fn (l, s) => s ^ "if CM.make \"" ^ l ^ "\" then () else OS.Process.exit OS.Process.failure;\n") "" (Config.cm config)
	119	in
8291a2b9	120	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");
c0a3b488 AC	121	TextIO.output (outf, libList);
	122	TextIO.output (outf, "Compiler.compileTemplates (Config.read \"mlt.conf\" (Config.default ())) ([");
	123	printMlts mlts;
	124	TextIO.output (outf, "], [");
	125	printMlts smls;
	126	TextIO.output (outf, "]);\n");
	127	TextIO.closeOut outf;
	128	OS.Process.system ("cat " ^ outPath ^ "/.build.sml \| " ^ sml ^ "/sml")
	129	end
	130
	131	fun compileTemplates config (mlts, smls) =
	132	let
8291a2b9	133	val err_flag = ref false
c0a3b488 AC	134	val _ = ErrorMsg.reset ()
	135
	136	val path = Config.inPath config
	137	val outPath = Config.outPath config
	138	val pubPath = Config.pubPath config
	139	val sml = Config.sml config
c0a3b488 AC	140
	141	val loc = Environment.staticPart (#get (EnvRef.loc ()) ())
	142	val base = Environment.staticPart (#get (EnvRef.base ()) ())
	143	val env = StaticEnv.atop (base, loc)
	144
	145	(*fun penv env = (print "I know about these symbols:\n";
	146	StaticEnv.app (fn (sym, _) => print (Symbol.describe sym ^ "\n")) env)
	147
	148	val _ = penv base
	149	val _ = penv loc*)
	150
	151	val templates = StringSet.addList (StringSet.empty, map (getFname o removeExt) mlts)
	152	val _ = print "Templates: "
	153	val _ = StringSet.app (fn s => print (s ^ "; ")) templates
	154	val _ = print "\n"
	155
	156	fun ct (fname, (exports, outputs, scripts)) =
	157	let
	158	val _ = print ("Compiling " ^ fname ^ "....\n")
	159	val (name, output) = compileTemplate (config, env, templates) fname
8291a2b9	160	val _ = err_flag := (!err_flag orelse !ErrorMsg.anyErrors)
c0a3b488	161	val scriptName = removeExt (getFname fname)
8291a2b9	162	val outName = "__" ^ scriptName ^ ".sml"
c0a3b488 AC	163	val outf = TextIO.openOut (outPath ^ "/" ^ outName)
	164	in
	165	TextIO.output (outf, output);
	166	TextIO.closeOut outf;
	167	(name :: exports, outName :: outputs, (pubPath ^ "/" ^ scriptName) :: scripts)
	168	end
	169
	170	val _ = print "Compiling templates....\n"
	171
	172	val (exports, outputs, scripts) = foldl ct ([], [], []) mlts
	173
	174	val outf = TextIO.openOut (outPath ^ "/_main.sml")
	175
b26ce3d9 AC	176	fun isTemplate x =
	177	let
	178	val x = makeName x
	179	in
	180	if List.exists (fn y => x = y) exports then
	181	SOME x
	182	else
	183	NONE
	184	end
	185	fun decide NONE = "(fn () => ())"
	186	\| decide (SOME t) =
	187	(case isTemplate t of
	188	SOME t => t ^ ".exec"
	189	\| _ => (err_flag := true;
	190	print ("Template " ^ t ^ " specified in mlt.conf does not exist!\n");
	191	"(fn () => ())"))
	192	val beforeT = decide (Config.beforeT config)
	193	val afterT = decide (Config.afterT config)
	194	val exnT = decide (Config.exnT config)
	195
	196	val _ = (TextIO.output (outf, "structure Templates :> TEMPLATES =\nstruct\n\tval beforeFn =");
	197	TextIO.output (outf, beforeT);
	198	TextIO.output (outf, "\n\tval afterFn = ");
	199	TextIO.output (outf, afterT);
	200	TextIO.output (outf, "\n\tval exnFn = ");
	201	TextIO.output (outf, exnT);
	202	TextIO.output (outf, "\n\n\tval templates = ["))
c0a3b488 AC	203	val _ = (case exports of
	204	[] => ()
	205	\| (exp::rest) => (TextIO.output (outf, "(\"" ^ exp ^ "\", " ^ exp ^ ".exec)");
	206	app (fn exp => TextIO.output (outf, ",\n\t\t(\"" ^ exp ^ "\", " ^ exp ^ ".exec)"))
	207	rest))
	208	val _ = TextIO.output (outf, "]\nend\n\nstructure Main = MainFn(Templates)\n")
	209	val _ = TextIO.closeOut outf
	210
16abb0f9	211	val outf = TextIO.openOut (outPath ^ "/.build.sml")
f1b55b48	212	val _ = TextIO.output (outf, "Control.printWarnings := false;\nprint \"Here we go\"\n;\nCM.make \"sources.cm\";\nSMLofNJ.exportFn (\"" ^ outPath ^ "/heap\", Main.main);\n")
16abb0f9 AC	213	val _ = TextIO.closeOut outf
16abb0f9 AC	214
c0a3b488 AC	215	val outf = TextIO.openOut (outPath ^ "/sources.cm")
	216	val printNames = app (fn name => TextIO.output (outf, "\t" ^ name ^ "\n"))
	217
	218	fun makeScript (name, str) =
	219	let
	220	val outf = TextIO.openOut name
	221	in
	222	TextIO.output (outf, "#!/bin/sh\n\n");
	223	TextIO.output (outf, sml ^ "/sml @SMLload=" ^ outPath ^ "/heap." ^ arch ^ " " ^ str ^ " $*\n");
	224	TextIO.closeOut outf;
	225	Posix.FileSys.chmod (name, cgiMode)
	226	end
	227	in
8291a2b9	228	if !err_flag then
c0a3b488 AC	229	(TextIO.print "Errors compiling templates.\n";
	230	OS.Process.failure)
	231	else
	232	(TextIO.output (outf, "(* Automatic generate web fun happyness )\n\nLibrary\n\tstructure Main\nis\n\t( Web library *)\n\t");
	233	TextIO.output (outf, Config.lib config);
	234	TextIO.output (outf, "\n\n\t(* Libraries *)\n\n");
	235	printNames (Config.cm config);
	236	TextIO.output (outf, "\n\t(* SML sources *)\n\n");
	237	printNames smls;
	238	TextIO.output (outf, "\n\t(* Templates *)\n\n");
	239	printNames outputs;
	240	TextIO.output (outf, "\n\t(* Driver *)\n\n\t_main.sml\n");
	241	TextIO.closeOut outf;
f1b55b48	242	if OS.Process.system ("cd " ^ outPath ^ " ; cat .build.sml \| " ^ sml ^ "/sml") = OS.Process.success then
c0a3b488 AC	243	(ListPair.app makeScript (scripts, exports);
	244	OS.Process.success)
	245	else
	246	OS.Process.failure)
	247	end
	248	end