src/compiler.sml

   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 compileTemplate (config, env, templates) path =
  85         let
  86             val fname = getFname path
  87             val name = removeExt fname
  88             val name =
  89                 if size name >= 1 then
  90                     str (toUpper (String.sub (name, 0))) ^ String.extract (name, 1, NONE)
  91                 else
  92                     raise Error
  93         in
  94             (name, Mlt.trans (config, env, templates, name, Parse.parse path))
  95         end
  96
  97     fun compileDirectory config =
  98         let
  99             val path = Config.inPath config
 100             val outPath = Config.outPath config
 101             val sml = Config.sml config
 102
 103             val dir = Posix.FileSys.opendir path
 104
 105             fun loop (smls, mlts) =
 106                 (case Posix.FileSys.readdir dir of
 107                      "" => (smls, mlts)
 108                    | fname =>
 109                      (case getExt fname of
 110                           "mlt" => loop (smls, (path ^ "/" ^ fname) :: mlts)
 111                         | ("sml"|"sig") =>
 112                           let
 113                               val mltName = removeExt fname ^ ".mlt"
 114                           in
 115                               if getFname fname = "_main.sml" orelse Posix.FileSys.access (mltName, []) then
 116                                   loop (smls, mlts)
 117                               else
 118                                   loop ((path ^ "/" ^ fname) :: smls, mlts)
 119                           end
 120                         | _ => loop (smls, mlts)))
 121
 122             val (smls, mlts) = loop ([], [])
 123
 124             val outf = TextIO.openOut (outPath ^ "/libs.cm")
 125             val printNames = app (fn name => TextIO.output (outf, "\t" ^ name ^ "\n"))
 126             val _ = TextIO.output (outf, "Group is\n\t");
 127             val _ = TextIO.output (outf, Config.lib config)
 128             val _ = TextIO.output (outf, "\n")
 129             val _ = TextIO.output (outf, "\n\t(* Extra libraries and such *)\n\n")
 130             val _ = printNames (Config.cm config)
 131             val _ = TextIO.output (outf, "\n\t(* Project SML sources *)\n\n")
 132             val _ = printNames smls
 133             val _ = TextIO.closeOut outf
 134
 135             val outf = TextIO.openOut (outPath ^ "/.build.sml")
 136             fun printMlts [] = ()
 137               | printMlts (h::t) =
 138                 (TextIO.output (outf, "\"" ^ h ^ "\"");
 139                  List.app (fn n => TextIO.output (outf, ", \"" ^ n ^ "\"")) t)
 140
 141             val libList = foldl (fn (l, s) => s ^ "if CM.make \"" ^ l ^ "\" then () else OS.Process.exit OS.Process.failure;\n") "" (Config.cm config)
 142         in
 143             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");
 144             TextIO.output (outf, libList);
 145             TextIO.output (outf, "Compiler.compileTemplates (Config.read \"mlt.conf\" (Config.default ())) ([");
 146             printMlts mlts;
 147             TextIO.output (outf, "], [");
 148             printMlts smls;
 149             TextIO.output (outf, "]);\n");
 150             TextIO.closeOut outf;
 151             OS.Process.system ("cat " ^ outPath ^ "/.build.sml | " ^ sml ^ "/sml")
 152         end
 153
 154     fun compileTemplates config (mlts, smls) =
 155         let
 156             val _ = ErrorMsg.reset ()
 157
 158             val path = Config.inPath config
 159             val outPath = Config.outPath config
 160             val pubPath = Config.pubPath config
 161             val sml = Config.sml config
 162             val arch = "x86-linux"
 163
 164             val loc = Environment.staticPart (#get (EnvRef.loc ()) ())
 165             val base = Environment.staticPart (#get (EnvRef.base ()) ())
 166             val env = StaticEnv.atop (base, loc)
 167
 168             (*fun penv env = (print "I know about these symbols:\n";
 169                             StaticEnv.app (fn (sym, _) => print (Symbol.describe sym ^ "\n")) env)
 170
 171             val _ = penv base
 172             val _ = penv loc*)
 173
 174             val templates = StringSet.addList (StringSet.empty, map (getFname o removeExt) mlts)
 175             val _ = print "Templates: "
 176             val _ = StringSet.app (fn s => print (s ^ "; ")) templates
 177             val _ = print "\n"
 178
 179             fun ct (fname, (exports, outputs, scripts)) =
 180                 let
 181                     val _ = print ("Compiling " ^ fname ^ "....\n")
 182                     val (name, output) = compileTemplate (config, env, templates) fname
 183                     val scriptName = removeExt (getFname fname)
 184                     val outName = scriptName ^ ".sml"
 185                     val outf = TextIO.openOut (outPath ^ "/" ^ outName)
 186                 in
 187                     TextIO.output (outf, output);
 188                     TextIO.closeOut outf;
 189                     (name :: exports, outName :: outputs, (pubPath ^ "/" ^ scriptName) :: scripts)
 190                 end
 191
 192             val _ = print "Compiling templates....\n"
 193
 194             val (exports, outputs, scripts) = foldl ct ([], [], []) mlts
 195
 196             val outf = TextIO.openOut (outPath ^ "/_main.sml")
 197
 198             val _ = TextIO.output (outf, "structure Templates :> TEMPLATES =\nstruct\n\tval templates = [")
 199             val _ = (case exports of
 200                          [] => ()
 201                        | (exp::rest) => (TextIO.output (outf, "(\"" ^ exp ^ "\", " ^ exp ^ ".exec)");
 202                                          app (fn exp => TextIO.output (outf, ",\n\t\t(\"" ^ exp ^ "\", " ^ exp ^ ".exec)"))
 203                                              rest))
 204             val _ = TextIO.output (outf, "]\nend\n\nstructure Main = MainFn(Templates)\n")
 205             val _ = TextIO.closeOut outf
 206
 207             val outf = TextIO.openOut (outPath ^ "/sources.cm")
 208             val printNames = app (fn name => TextIO.output (outf, "\t" ^ name ^ "\n"))
 209
 210             fun makeScript (name, str) =
 211                 let
 212                     val outf = TextIO.openOut name
 213                 in
 214                     TextIO.output (outf, "#!/bin/sh\n\n");
 215                     TextIO.output (outf, sml ^ "/sml @SMLload=" ^ outPath ^ "/heap." ^ arch ^ " " ^ str ^ " $*\n");
 216                     TextIO.closeOut outf;
 217                     Posix.FileSys.chmod (name, cgiMode)
 218                 end
 219         in
 220             if !ErrorMsg.anyErrors then
 221                 (TextIO.print "Errors compiling templates.\n";
 222                  OS.Process.failure)
 223             else
 224                 (TextIO.output (outf, "(* Automatic generate web fun happyness *)\n\nLibrary\n\tstructure Main\nis\n\t(* Web library *)\n\t");
 225                  TextIO.output (outf, Config.lib config);
 226                  TextIO.output (outf, "\n\n\t(* Libraries *)\n\n");
 227                  printNames (Config.cm config);
 228                  TextIO.output (outf, "\n\t(* SML sources *)\n\n");
 229                  printNames smls;
 230                  TextIO.output (outf, "\n\t(* Templates *)\n\n");
 231                  printNames outputs;
 232                  TextIO.output (outf, "\n\t(* Driver *)\n\n\t_main.sml\n");
 233                  TextIO.closeOut outf;
 234                  if OS.Process.system (sml ^ "/ml-build " ^ outPath ^ "/sources.cm Main.main " ^ outPath ^ "/heap") = OS.Process.success then
 235                      (ListPair.app makeScript (scripts, exports);
 236                       OS.Process.success)
 237                  else
 238                      OS.Process.failure)
 239         end
 240 end