Switch to using OS.Path in Compiler

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

diff --git a/src/compiler.sml b/src/compiler.sml
index e87cb57..cd03d6c 100644 (file)
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -21,6 +21,8 @@
 
 structure Compiler :> COMPILER =
 struct
+    open Settings
+
     exception Error
 
     val cgiMode = Posix.FileSys.S.flags [Posix.FileSys.S.irwxu,
@@ -31,48 +33,14 @@ struct
                    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
+    val getFname = OS.Path.file
 
-           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
+    val removeExt = OS.Path.base
 
     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
+       case OS.Path.ext path of
+           NONE => path
+         | SOME ext => ext
 
     val upperOffset = ord #"A" - ord #"a"
     fun toUpper ch =
@@ -81,16 +49,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
@@ -105,8 +80,8 @@ 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") =>
@@ -134,7 +109,7 @@ struct
            val _ = TextIO.closeOut outf
            
            val outf = TextIO.openOut (outPath ^ "/.build.sml")
-           val _ = TextIO.output (outf, "Control.quotation := true;\n")
+           val _ = TextIO.output (outf, "Control.quotation := true;\nControl.printWarnings := false;\n")
            fun printMlts [] = ()
              | printMlts (h::t) =
                (TextIO.output (outf, "\"" ^ h ^ "\"");
@@ -162,7 +137,6 @@ struct
            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 ()) ())
@@ -199,7 +173,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)");
@@ -208,6 +208,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;\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"))
 
@@ -235,7 +239,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 ("cd " ^ outPath ^ " ; cat .build.sml | " ^ sml ^ "/sml") = OS.Process.success then
                     (ListPair.app makeScript (scripts, exports);
                      OS.Process.success)
                 else