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 | ||
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 | ||
b26ce3d9 | 86 | fun makeName name = |
c0a3b488 | 87 | let |
c0a3b488 AC |
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 | |
8291a2b9 | 93 | val name = name ^ "_" |
b26ce3d9 AC |
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 | |
c0a3b488 AC |
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 | |
dca24e57 AC |
117 | NONE => (smls, mlts) |
118 | | SOME fname => | |
c0a3b488 AC |
119 | (case getExt fname of |
120 | "mlt" => loop (smls, (path ^ "/" ^ fname) :: mlts) | |
121 | | ("sml"|"sig") => | |
122 | let | |
8291a2b9 | 123 | val fname = getFname fname |
c0a3b488 | 124 | in |
8291a2b9 | 125 | if String.sub (fname, 0) = #"_" then |
c0a3b488 AC |
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") | |
16abb0f9 | 146 | val _ = TextIO.output (outf, "Control.quotation := true;\nControl.printWarnings := false;\n") |
c0a3b488 AC |
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 | |
8291a2b9 | 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"); |
c0a3b488 AC |
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 | |
8291a2b9 | 167 | val err_flag = ref false |
c0a3b488 AC |
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 | |
c0a3b488 AC |
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 | |
8291a2b9 | 194 | val _ = err_flag := (!err_flag orelse !ErrorMsg.anyErrors) |
c0a3b488 | 195 | val scriptName = removeExt (getFname fname) |
8291a2b9 | 196 | val outName = "__" ^ scriptName ^ ".sml" |
c0a3b488 AC |
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 | ||
b26ce3d9 AC |
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 = [")) | |
c0a3b488 AC |
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 | ||
16abb0f9 | 245 | val outf = TextIO.openOut (outPath ^ "/.build.sml") |
f1b55b48 | 246 | 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 |
247 | val _ = TextIO.closeOut outf |
248 | ||
c0a3b488 AC |
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 | |
8291a2b9 | 262 | if !err_flag then |
c0a3b488 AC |
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; | |
f1b55b48 | 276 | if OS.Process.system ("cd " ^ outPath ^ " ; cat .build.sml | " ^ sml ^ "/sml") = OS.Process.success then |
c0a3b488 AC |
277 | (ListPair.app makeScript (scripts, exports); |
278 | OS.Process.success) | |
279 | else | |
280 | OS.Process.failure) | |
281 | end | |
282 | end |