Mercurial > urweb

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