Updated for SML/NJ 110.46+

[bpt/mlt.git] / src / compiler.sml

diff --git a/src/compiler.sml b/src/compiler.sml
index 6ef2807..aa4db33 100644 (file)
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -81,15 +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
@@ -104,15 +112,15 @@ struct
 
            fun loop (smls, mlts) =
                (case Posix.FileSys.readdir dir of
-                    "" => (smls, mlts)
-                  | fname =>
+                    NONE => (smls, mlts)
+                  | SOME fname =>
                     (case getExt fname of
                          "mlt" => loop (smls, (path ^ "/" ^ fname) :: mlts)
                        | ("sml"|"sig") =>
                          let
-                             val mltName = removeExt fname ^ ".mlt"
+                             val fname = getFname fname
                          in
-                             if getFname fname = "_main.sml" orelse Posix.FileSys.access (mltName, []) then
+                             if String.sub (fname, 0) = #"_" then
                                  loop (smls, mlts)
                              else
                                  loop ((path ^ "/" ^ fname) :: smls, mlts)
@@ -133,6 +141,7 @@ struct
            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 ^ "\"");
@@ -140,7 +149,7 @@ struct
 
            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;\n");
+           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;
@@ -153,6 +162,7 @@ struct
        
     fun compileTemplates config (mlts, smls) =
        let
+           val err_flag = ref false
            val _ = ErrorMsg.reset ()
 
            val path = Config.inPath config
@@ -180,8 +190,9 @@ struct
                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 outName = "__" ^ scriptName ^ ".sml"
                    val outf = TextIO.openOut (outPath ^ "/" ^ outName)
                in
                    TextIO.output (outf, output);
@@ -195,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)");
@@ -204,6 +241,10 @@ struct
            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"))
 
@@ -217,7 +258,7 @@ struct
                    Posix.FileSys.chmod (name, cgiMode)
                end
        in
-           if !ErrorMsg.anyErrors then
+           if !err_flag then
                (TextIO.print "Errors compiling templates.\n";
                 OS.Process.failure)
            else
@@ -231,7 +272,7 @@ struct
                 printNames outputs;
                 TextIO.output (outf, "\n\t(* Driver *)\n\n\t_main.sml\n");
                 TextIO.closeOut outf;
-                if OS.Process.system (sml ^ "/ml-build " ^ outPath ^ "/sources.cm Main.main " ^ outPath ^ "/heap") = OS.Process.success then
+                if OS.Process.system ("cat " ^ outPath ^ "/.build.sml | " ^ sml ^ "/sml") = OS.Process.success then
                     (ListPair.app makeScript (scripts, exports);
                      OS.Process.success)
                 else