(*
 * 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