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