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