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
=
28 val cgiMode
= Posix
.FileSys
.S
.flags
[Posix
.FileSys
.S
.irwxu
,
29 Posix
.FileSys
.S
.iroth
,
30 Posix
.FileSys
.S
.ixoth
]
32 val consumer
= {consumer
= TextIO.print
,
33 flush
= fn () => TextIO.flushOut
TextIO.stdOut
,
36 val getFname
= OS
.Path
.file
38 val removeExt
= OS
.Path
.base
41 case OS
.Path
.ext path
of
45 val upperOffset
= ord #
"A" - ord #
"a"
47 if Char.isLower ch
then
48 chr (ord ch
+ upperOffset
)
55 if size name
>= 1 then
56 str (toUpper (String.sub (name
, 0))) ^
String.extract (name
, 1, NONE
)
64 fun compileTemplate (config
, env
, templates
) path
=
66 val fname
= getFname path
67 val name
= removeExt fname
68 val name
= makeName name
70 (name
, Mlt
.trans (config
, env
, templates
, name
, Parse
.parse path
))
73 fun compileDirectory config
=
75 val path
= Config
.inPath config
76 val outPath
= Config
.outPath config
77 val sml
= Config
.sml config
79 val dir
= Posix
.FileSys
.opendir path
81 fun loop (smls
, mlts
) =
82 (case Posix
.FileSys
.readdir dir
of
86 "mlt" => loop (smls
, (path ^
"/" ^ fname
) :: mlts
)
89 val fname
= getFname fname
91 if String.sub (fname
, 0) = #
"_" then
94 loop ((path ^
"/" ^ fname
) :: smls
, mlts
)
96 | _
=> loop (smls
, mlts
)))
98 val (smls
, mlts
) = loop ([], [])
100 val outf
= TextIO.openOut (outPath ^
"/libs.cm")
101 val printNames
= app (fn name
=> TextIO.output (outf
, "\t" ^ name ^
"\n"))
102 val _
= TextIO.output (outf
, "Group is\n\t");
103 val _
= TextIO.output (outf
, Config
.lib config
)
104 val _
= TextIO.output (outf
, "\n")
105 val _
= TextIO.output (outf
, "\n\t(* Extra libraries and such *)\n\n")
106 val _
= printNames (Config
.cm config
)
107 val _
= TextIO.output (outf
, "\n\t(* Project SML sources *)\n\n")
108 val _
= printNames smls
109 val _
= TextIO.closeOut outf
111 val outf
= TextIO.openOut (outPath ^
"/.build.sml")
112 val _
= TextIO.output (outf
, "Control.quotation := true;\nControl.printWarnings := false;\n")
113 fun printMlts
[] = ()
115 (TextIO.output (outf
, "\"" ^ h ^
"\"");
116 List.app (fn n
=> TextIO.output (outf
, ", \"" ^ n ^
"\"")) t
)
118 val libList
= foldl (fn (l
, s
) => s ^
"if CM.make \"" ^ l ^
"\" then () else OS.Process.exit OS.Process.failure;\n") "" (Config
.cm config
)
120 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");
121 TextIO.output (outf
, libList
);
122 TextIO.output (outf
, "Compiler.compileTemplates (Config.read \"mlt.conf\" (Config.default ())) ([");
124 TextIO.output (outf
, "], [");
126 TextIO.output (outf
, "]);\n");
127 TextIO.closeOut outf
;
128 OS
.Process
.system ("cat " ^ outPath ^
"/.build.sml | " ^ sml ^
"/sml")
131 fun compileTemplates
config (mlts
, smls
) =
133 val err_flag
= ref
false
134 val _
= ErrorMsg
.reset ()
136 val path
= Config
.inPath config
137 val outPath
= Config
.outPath config
138 val pubPath
= Config
.pubPath config
139 val sml
= Config
.sml config
141 val loc
= Environment
.staticPart (#
get (EnvRef
.loc ()) ())
142 val base
= Environment
.staticPart (#
get (EnvRef
.base ()) ())
143 val env
= StaticEnv
.atop (base
, loc
)
145 (*fun penv env
= (print
"I know about these symbols:\n";
146 StaticEnv
.app (fn (sym
, _
) => print (Symbol
.describe sym ^
"\n")) env
)
151 val templates
= StringSet
.addList (StringSet
.empty
, map (getFname
o removeExt
) mlts
)
152 val _
= print
"Templates: "
153 val _
= StringSet
.app (fn s
=> print (s ^
"; ")) templates
156 fun ct (fname
, (exports
, outputs
, scripts
)) =
158 val _
= print ("Compiling " ^ fname ^
"....\n")
159 val (name
, output
) = compileTemplate (config
, env
, templates
) fname
160 val _
= err_flag
:= (!err_flag
orelse !ErrorMsg
.anyErrors
)
161 val scriptName
= removeExt (getFname fname
)
162 val outName
= "__" ^ scriptName ^
".sml"
163 val outf
= TextIO.openOut (outPath ^
"/" ^ outName
)
165 TextIO.output (outf
, output
);
166 TextIO.closeOut outf
;
167 (name
:: exports
, outName
:: outputs
, (pubPath ^
"/" ^ scriptName
) :: scripts
)
170 val _
= print
"Compiling templates....\n"
172 val (exports
, outputs
, scripts
) = foldl
ct ([], [], []) mlts
174 val outf
= TextIO.openOut (outPath ^
"/_main.sml")
180 if List.exists (fn y
=> x
= y
) exports
then
185 fun decide NONE
= "(fn () => ())"
187 (case isTemplate t
of
188 SOME t
=> t ^
".exec"
189 | _
=> (err_flag
:= true;
190 print ("Template " ^ t ^
" specified in mlt.conf does not exist!\n");
192 val beforeT
= decide (Config
.beforeT config
)
193 val afterT
= decide (Config
.afterT config
)
194 val exnT
= decide (Config
.exnT config
)
196 val _
= (TextIO.output (outf
, "structure Templates :> TEMPLATES =\nstruct\n\tval beforeFn =");
197 TextIO.output (outf
, beforeT
);
198 TextIO.output (outf
, "\n\tval afterFn = ");
199 TextIO.output (outf
, afterT
);
200 TextIO.output (outf
, "\n\tval exnFn = ");
201 TextIO.output (outf
, exnT
);
202 TextIO.output (outf
, "\n\n\tval templates = ["))
203 val _
= (case exports
of
205 |
(exp
::rest
) => (TextIO.output (outf
, "(\"" ^ exp ^
"\", " ^ exp ^
".exec)");
206 app (fn exp
=> TextIO.output (outf
, ",\n\t\t(\"" ^ exp ^
"\", " ^ exp ^
".exec)"))
208 val _
= TextIO.output (outf
, "]\nend\n\nstructure Main = MainFn(Templates)\n")
209 val _
= TextIO.closeOut outf
211 val outf
= TextIO.openOut (outPath ^
"/.build.sml")
212 val _
= TextIO.output (outf
, "Control.printWarnings := false;\nprint \"Here we go\"\n;\nCM.make \"sources.cm\";\nSMLofNJ.exportFn (\"" ^ outPath ^
"/heap\", Main.main);\n")
213 val _
= TextIO.closeOut outf
215 val outf
= TextIO.openOut (outPath ^
"/sources.cm")
216 val printNames
= app (fn name
=> TextIO.output (outf
, "\t" ^ name ^
"\n"))
218 fun makeScript (name
, str
) =
220 val outf
= TextIO.openOut name
222 TextIO.output (outf
, "#!/bin/sh\n\n");
223 TextIO.output (outf
, sml ^
"/sml @SMLload=" ^ outPath ^
"/heap." ^ arch ^
" " ^ str ^
" $*\n");
224 TextIO.closeOut outf
;
225 Posix
.FileSys
.chmod (name
, cgiMode
)
229 (TextIO.print
"Errors compiling templates.\n";
232 (TextIO.output (outf
, "(* Automatic generate web fun happyness *)\n\nLibrary\n\tstructure Main\nis\n\t(* Web library *)\n\t");
233 TextIO.output (outf
, Config
.lib config
);
234 TextIO.output (outf
, "\n\n\t(* Libraries *)\n\n");
235 printNames (Config
.cm config
);
236 TextIO.output (outf
, "\n\t(* SML sources *)\n\n");
238 TextIO.output (outf
, "\n\t(* Templates *)\n\n");
240 TextIO.output (outf
, "\n\t(* Driver *)\n\n\t_main.sml\n");
241 TextIO.closeOut outf
;
242 if OS
.Process
.system ("cd " ^ outPath ^
" ; cat .build.sml | " ^ sml ^
"/sml") = OS
.Process
.success
then
243 (ListPair.app
makeScript (scripts
, exports
);