2 * Dynamic web page generation
with Standard ML
3 * Copyright (C
) 2003 Adam Chlipala
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
.
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
.
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
20 (* Template compiler interface
*)
22 structure Compiler
:> COMPILER
=
26 val cgiMode
= Posix
.FileSys
.S
.flags
[Posix
.FileSys
.S
.irwxu
,
27 Posix
.FileSys
.S
.iroth
,
28 Posix
.FileSys
.S
.ixoth
]
30 val consumer
= {consumer
= TextIO.print
,
31 flush
= fn () => TextIO.flushOut
TextIO.stdOut
,
39 else if String.sub (path
, i
) = #
"/" then
40 String.extract (path
, i
+1, NONE
)
54 else if String.sub (path
, i
) = #
"." then
55 String.substring (path
, 0, i
)
69 else if String.sub (path
, i
) = #
"." then
70 String.extract (path
, i
+1, NONE
)
77 val upperOffset
= ord #
"A" - ord #
"a"
79 if Char.isLower ch
then
80 chr (ord ch
+ upperOffset
)
87 if size name
>= 1 then
88 str (toUpper (String.sub (name
, 0))) ^
String.extract (name
, 1, NONE
)
96 fun compileTemplate (config
, env
, templates
) path
=
98 val fname
= getFname path
99 val name
= removeExt fname
100 val name
= makeName name
102 (name
, Mlt
.trans (config
, env
, templates
, name
, Parse
.parse path
))
105 fun compileDirectory config
=
107 val path
= Config
.inPath config
108 val outPath
= Config
.outPath config
109 val sml
= Config
.sml config
111 val dir
= Posix
.FileSys
.opendir path
113 fun loop (smls
, mlts
) =
114 (case Posix
.FileSys
.readdir dir
of
117 (case getExt fname
of
118 "mlt" => loop (smls
, (path ^
"/" ^ fname
) :: mlts
)
121 val fname
= getFname fname
123 if String.sub (fname
, 0) = #
"_" then
126 loop ((path ^
"/" ^ fname
) :: smls
, mlts
)
128 | _
=> loop (smls
, mlts
)))
130 val (smls
, mlts
) = loop ([], [])
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
143 val outf
= TextIO.openOut (outPath ^
"/.build.sml")
144 val _
= TextIO.output (outf
, "Control.quotation := true;\nControl.printWarnings := false;\n")
145 fun printMlts
[] = ()
147 (TextIO.output (outf
, "\"" ^ h ^
"\"");
148 List.app (fn n
=> TextIO.output (outf
, ", \"" ^ n ^
"\"")) t
)
150 val libList
= foldl (fn (l
, s
) => s ^
"if CM.make \"" ^ l ^
"\" then () else OS.Process.exit OS.Process.failure;\n") "" (Config
.cm config
)
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");
153 TextIO.output (outf
, libList
);
154 TextIO.output (outf
, "Compiler.compileTemplates (Config.read \"mlt.conf\" (Config.default ())) ([");
156 TextIO.output (outf
, "], [");
158 TextIO.output (outf
, "]);\n");
159 TextIO.closeOut outf
;
160 OS
.Process
.system ("cat " ^ outPath ^
"/.build.sml | " ^ sml ^
"/sml")
163 fun compileTemplates
config (mlts
, smls
) =
165 val err_flag
= ref
false
166 val _
= ErrorMsg
.reset ()
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"
174 val loc
= Environment
.staticPart (#
get (EnvRef
.loc ()) ())
175 val base
= Environment
.staticPart (#
get (EnvRef
.base ()) ())
176 val env
= StaticEnv
.atop (base
, loc
)
178 (*fun penv env
= (print
"I know about these symbols:\n";
179 StaticEnv
.app (fn (sym
, _
) => print (Symbol
.describe sym ^
"\n")) env
)
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
189 fun ct (fname
, (exports
, outputs
, scripts
)) =
191 val _
= print ("Compiling " ^ fname ^
"....\n")
192 val (name
, output
) = compileTemplate (config
, env
, templates
) fname
193 val _
= err_flag
:= (!err_flag
orelse !ErrorMsg
.anyErrors
)
194 val scriptName
= removeExt (getFname fname
)
195 val outName
= "__" ^ scriptName ^
".sml"
196 val outf
= TextIO.openOut (outPath ^
"/" ^ outName
)
198 TextIO.output (outf
, output
);
199 TextIO.closeOut outf
;
200 (name
:: exports
, outName
:: outputs
, (pubPath ^
"/" ^ scriptName
) :: scripts
)
203 val _
= print
"Compiling templates....\n"
205 val (exports
, outputs
, scripts
) = foldl
ct ([], [], []) mlts
207 val outf
= TextIO.openOut (outPath ^
"/_main.sml")
213 if List.exists (fn y
=> x
= y
) exports
then
218 fun decide NONE
= "(fn () => ())"
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");
225 val beforeT
= decide (Config
.beforeT config
)
226 val afterT
= decide (Config
.afterT config
)
227 val exnT
= decide (Config
.exnT config
)
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 = ["))
236 val _
= (case exports
of
238 |
(exp
::rest
) => (TextIO.output (outf
, "(\"" ^ exp ^
"\", " ^ exp ^
".exec)");
239 app (fn exp
=> TextIO.output (outf
, ",\n\t\t(\"" ^ exp ^
"\", " ^ exp ^
".exec)"))
241 val _
= TextIO.output (outf
, "]\nend\n\nstructure Main = MainFn(Templates)\n")
242 val _
= TextIO.closeOut outf
244 val outf
= TextIO.openOut (outPath ^
"/.build.sml")
245 val _
= TextIO.output (outf
, "Control.printWarnings := false;\nCM.make \"sources.cm\";\nSMLofNJ.exportFn (\"" ^ outPath ^
"/heap\", Main.main);\n")
246 val _
= TextIO.closeOut outf
248 val outf
= TextIO.openOut (outPath ^
"/sources.cm")
249 val printNames
= app (fn name
=> TextIO.output (outf
, "\t" ^ name ^
"\n"))
251 fun makeScript (name
, str
) =
253 val outf
= TextIO.openOut name
255 TextIO.output (outf
, "#!/bin/sh\n\n");
256 TextIO.output (outf
, sml ^
"/sml @SMLload=" ^ outPath ^
"/heap." ^ arch ^
" " ^ str ^
" $*\n");
257 TextIO.closeOut outf
;
258 Posix
.FileSys
.chmod (name
, cgiMode
)
262 (TextIO.print
"Errors compiling templates.\n";
265 (TextIO.output (outf
, "(* Automatic generate web fun happyness *)\n\nLibrary\n\tstructure Main\nis\n\t(* Web library *)\n\t");
266 TextIO.output (outf
, Config
.lib config
);
267 TextIO.output (outf
, "\n\n\t(* Libraries *)\n\n");
268 printNames (Config
.cm config
);
269 TextIO.output (outf
, "\n\t(* SML sources *)\n\n");
271 TextIO.output (outf
, "\n\t(* Templates *)\n\n");
273 TextIO.output (outf
, "\n\t(* Driver *)\n\n\t_main.sml\n");
274 TextIO.closeOut outf
;
275 if OS
.Process
.system ("cat " ^ outPath ^
"/.build.sml | " ^ sml ^
"/sml") = OS
.Process
.success
then
276 (ListPair.app
makeScript (scripts
, exports
);