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