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