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