Mercurial > urweb

comparison src/tutorial.sml @ 1493:9cb923efea4d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Generated pretty-printed HTML for a simple tutorial source file
author Adam Chlipala <adam@chlipala.net>
date Fri, 15 Jul 2011 16:50:55 -0400
parents
children 9ef6dd0df7a0
comparison
equal deleted inserted replaced
1492:175b6d52252d 1493:9cb923efea4d
1 (* Copyright (c) 2011, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 structure Tutorial :> TUTORIAL = struct
29
30 fun readAll' inf =
31 let
32 fun loop acc =
33 case TextIO.inputLine inf of
34 NONE => Substring.full (String.concat (rev acc))
35 | SOME line => loop (line :: acc)
36 in
37 loop []
38 before TextIO.closeIn inf
39 end
40
41 fun readAll fname = readAll' (TextIO.openIn fname)
42
43 fun doUr fname =
44 let
45 val eval = TextIO.openOut "/tmp/eval.ur"
46 val gen = TextIO.openOut "/tmp/gen.ur"
47
48 fun untilEnd source =
49 let
50 val (befor, after) = Substring.position "(* end *)" source
51 in
52 if Substring.isEmpty after then
53 (source, Substring.full "")
54 else
55 (befor, Substring.slice (after, 9, NONE))
56 end
57
58 fun doDirectives (count, source) =
59 let
60 val safe = String.translate (fn #"<" => "&lt;"
61 | #"&" => "&amp;"
62 | #"{" => "&#123;"
63 | #"(" => "&#40;"
64 | #"\n" => "&#40;*NL*)\n"
65 | ch => str ch) o Substring.string
66
67 val (befor, after) = Substring.position "(* begin " source
68
69 fun default () = (TextIO.outputSubstr (eval, source);
70 TextIO.output (gen, safe source))
71 in
72 if Substring.isEmpty after then
73 default ()
74 else
75 let
76 val (command, after) = Substring.splitl (not o Char.isSpace) (Substring.slice (after, 9, NONE))
77 in
78 if Substring.isEmpty after then
79 default ()
80 else
81 let
82 val (_, rest) = Substring.position "*)" after
83 in
84 if Substring.isEmpty rest then
85 default ()
86 else
87 let
88 val (arg, source) = untilEnd (Substring.slice (rest, 3, NONE))
89 val () = (TextIO.outputSubstr (eval, befor);
90 TextIO.output (gen, safe befor))
91 val (count, skip) =
92 case Substring.string command of
93 "hide" => (TextIO.outputSubstr (eval, arg);
94 (count, true))
95 | "eval" => (TextIO.output (eval, "val _eval");
96 TextIO.output (eval, Int.toString count);
97 TextIO.output (eval, " = ");
98 TextIO.outputSubstr (eval, arg);
99 TextIO.output (eval, "\n\n");
100
101 TextIO.output (gen, safe arg);
102 TextIO.output (gen, "== {[_eval");
103 TextIO.output (gen, Int.toString count);
104 TextIO.output (gen, "]}");
105
106 (count + 1, false))
107 | s => raise Fail ("Unknown tutorial directive: " ^ s)
108 in
109 doDirectives (count, if skip then
110 #2 (Substring.splitl Char.isSpace source)
111 else
112 source)
113 end
114 end
115 end
116 end
117 in
118 doDirectives (0, readAll fname);
119 TextIO.closeOut gen;
120
121 TextIO.output (eval, "\n\nfun main () : transaction page =\nreturn <xml><body>");
122 TextIO.outputSubstr (eval, readAll "/tmp/gen.ur");
123 TextIO.output (eval, "</body></xml>");
124 TextIO.closeOut eval;
125
126 if Compiler.compile "/tmp/eval" then
127 let
128 val proc = Unix.execute ("/bin/sh", ["-c", "/tmp/eval.exe /main"])
129 val inf = Unix.textInstreamOf proc
130 val s = readAll' inf
131 val _ = Unix.reap proc
132
133 val (befor, after) = Substring.position "<sc>" s
134 in
135 if Substring.isEmpty after then
136 print ("Bad output for " ^ fname ^ "! [1]\n")
137 else
138 let
139 val after = Substring.slice (after, 4, NONE)
140 val (befor, after) = Substring.position "</body>" after
141 in
142 if Substring.isEmpty after then
143 print ("Bad output for " ^ fname ^ "! [2]\n")
144 else
145 let
146 val outf = TextIO.openOut "/tmp/final.ur"
147
148 fun eatNls source =
149 let
150 val (befor, after) = Substring.position "(*NL*)" source
151 in
152 if Substring.isEmpty after then
153 TextIO.outputSubstr (outf, source)
154 else
155 (TextIO.outputSubstr (outf, befor);
156 eatNls (Substring.slice (after, 6, NONE)))
157 end
158
159 val cmd = "emacs --eval \"(progn "
160 ^ "(global-font-lock-mode t) "
161 ^ "(add-to-list 'load-path \\\""
162 ^ Config.sitelisp
163 ^ "/\\\") "
164 ^ "(load \\\"urweb-mode-startup\\\") "
165 ^ "(urweb-mode) "
166 ^ "(find-file \\\"/tmp/final.ur\\\") "
167 ^ "(switch-to-buffer (htmlize-buffer)) "
168 ^ "(write-file \\\""
169 ^ OS.Path.mkAbsolute {relativeTo = OS.FileSys.getDir (),
170 path = OS.Path.joinBaseExt {base = OS.Path.base fname, ext = SOME "html"}}
171 ^ "\\\") "
172 ^ "(kill-emacs))\""
173 in
174 eatNls befor;
175 TextIO.closeOut outf;
176 ignore (OS.Process.system cmd)
177 end
178 end
179 end
180 else
181 ()
182 end
183
184 fun make dirname =
185 let
186 val dir = OS.FileSys.openDir dirname
187
188 fun doDir () =
189 case OS.FileSys.readDir dir of
190 NONE => OS.FileSys.closeDir dir
191 | SOME fname =>
192 (if OS.Path.ext fname = SOME "ur" then
193 doUr (OS.Path.joinDirFile {dir = dirname, file = fname})
194 else
195 ();
196 doDir ())
197 in
198 Settings.setProtocol "static";
199 doDir ()
200 end
201
202 end