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
)
84 fun compileTemplate (config
, env
, templates
) path
=
86 val fname
= getFname path
87 val name
= removeExt fname
89 if size name
>= 1 then
90 str (toUpper (String.sub (name
, 0))) ^
String.extract (name
, 1, NONE
)
94 (name
, Mlt
.trans (config
, env
, templates
, name
, Parse
.parse path
))
97 fun compileDirectory config
=
99 val path
= Config
.inPath config
100 val outPath
= Config
.outPath config
101 val sml
= Config
.sml config
103 val dir
= Posix
.FileSys
.opendir path
105 fun loop (smls
, mlts
) =
106 (case Posix
.FileSys
.readdir dir
of
109 (case getExt fname
of
110 "mlt" => loop (smls
, (path ^
"/" ^ fname
) :: mlts
)
113 val mltName
= removeExt fname ^
".mlt"
115 if getFname fname
= "_main.sml" orelse Posix
.FileSys
.access (mltName
, []) then
118 loop ((path ^
"/" ^ fname
) :: smls
, mlts
)
120 | _
=> loop (smls
, mlts
)))
122 val (smls
, mlts
) = loop ([], [])
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
135 val outf
= TextIO.openOut (outPath ^
"/.build.sml")
136 fun printMlts
[] = ()
138 (TextIO.output (outf
, "\"" ^ h ^
"\"");
139 List.app (fn n
=> TextIO.output (outf
, ", \"" ^ n ^
"\"")) t
)
141 val libList
= foldl (fn (l
, s
) => s ^
"if CM.make \"" ^ l ^
"\" then () else OS.Process.exit OS.Process.failure;\n") "" (Config
.cm config
)
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 ())) ([");
147 TextIO.output (outf
, "], [");
149 TextIO.output (outf
, "]);\n");
150 TextIO.closeOut outf
;
151 OS
.Process
.system ("cat " ^ outPath ^
"/.build.sml | " ^ sml ^
"/sml")
154 fun compileTemplates
config (mlts
, smls
) =
156 val _
= ErrorMsg
.reset ()
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"
164 val loc
= Environment
.staticPart (#
get (EnvRef
.loc ()) ())
165 val base
= Environment
.staticPart (#
get (EnvRef
.base ()) ())
166 val env
= StaticEnv
.atop (base
, loc
)
168 (*fun penv env
= (print
"I know about these symbols:\n";
169 StaticEnv
.app (fn (sym
, _
) => print (Symbol
.describe sym ^
"\n")) env
)
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
179 fun ct (fname
, (exports
, outputs
, scripts
)) =
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
)
187 TextIO.output (outf
, output
);
188 TextIO.closeOut outf
;
189 (name
:: exports
, outName
:: outputs
, (pubPath ^
"/" ^ scriptName
) :: scripts
)
192 val _
= print
"Compiling templates....\n"
194 val (exports
, outputs
, scripts
) = foldl
ct ([], [], []) mlts
196 val outf
= TextIO.openOut (outPath ^
"/_main.sml")
198 val _
= TextIO.output (outf
, "structure Templates :> TEMPLATES =\nstruct\n\tval templates = [")
199 val _
= (case exports
of
201 |
(exp
::rest
) => (TextIO.output (outf
, "(\"" ^ exp ^
"\", " ^ exp ^
".exec)");
202 app (fn exp
=> TextIO.output (outf
, ",\n\t\t(\"" ^ exp ^
"\", " ^ exp ^
".exec)"))
204 val _
= TextIO.output (outf
, "]\nend\n\nstructure Main = MainFn(Templates)\n")
205 val _
= TextIO.closeOut outf
207 val outf
= TextIO.openOut (outPath ^
"/sources.cm")
208 val printNames
= app (fn name
=> TextIO.output (outf
, "\t" ^ name ^
"\n"))
210 fun makeScript (name
, str
) =
212 val outf
= TextIO.openOut name
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
)
220 if !ErrorMsg
.anyErrors
then
221 (TextIO.print
"Errors compiling templates.\n";
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");
230 TextIO.output (outf
, "\n\t(* Templates *)\n\n");
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
);