Commit | Line | Data |
---|---|---|
234b917a AC |
1 | (* HCoop Domtool (http://hcoop.sourceforge.net/) |
2 | * Copyright (c) 2006, Adam Chlipala | |
3 | * | |
4 | * This program is free software; you can redistribute it and/or | |
5 | * modify it under the terms of the GNU General Public License | |
6 | * as published by the Free Software Foundation; either version 2 | |
7 | * of the License, or (at your option) any later version. | |
8 | * | |
9 | * This program is distributed in the hope that it will be useful, | |
10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
12 | * GNU General Public License for more details. | |
13 | * | |
14 | * You should have received a copy of the GNU General Public License | |
15 | * along with this program; if not, write to the Free Software | |
16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. | |
dac62e84 | 17 | *) |
234b917a AC |
18 | |
19 | (* Main interface *) | |
20 | ||
21 | structure Main :> MAIN = struct | |
22 | ||
492c1cff | 23 | open Ast Print |
234b917a | 24 | |
6ae327f8 AC |
25 | structure SM = StringMap |
26 | ||
234b917a AC |
27 | val dmy = ErrorMsg.dummyLoc |
28 | ||
559e89e9 AC |
29 | fun init () = (F_OpenSSL_SML_add_all_algorithms.f' (); |
30 | F_OpenSSL_SML_load_error_strings.f' (); | |
31 | F_OpenSSL_SML_load_BIO_strings.f' ()) | |
32 | ||
33 | val () = init () | |
34 | ||
6ae327f8 | 35 | val defaultT : record ref = ref SM.empty |
8a7c40fa | 36 | val defaultV : (unit -> exp) SM.map ref = ref SM.empty |
6ae327f8 AC |
37 | |
38 | fun registerDefault (name, t, v) = | |
39 | case SM.find (!defaultT, name) of | |
40 | NONE => (defaultT := SM.insert (!defaultT, name, t); | |
41 | defaultV := SM.insert (!defaultV, name, v)) | |
42 | | SOME _ => raise Fail "Duplicate default environment variable" | |
43 | ||
44 | fun tInit () = (TAction ((CRoot, dmy), | |
45 | !defaultT, | |
46 | StringMap.empty), | |
47 | dmy) | |
d189ec0e AC |
48 | |
49 | ||
234b917a | 50 | |
d189ec0e | 51 | fun check' G fname = |
a3698041 | 52 | let |
d189ec0e | 53 | (*val _ = print ("Check " ^ fname ^ "\n")*) |
a3698041 AC |
54 | val prog = Parse.parse fname |
55 | in | |
56 | if !ErrorMsg.anyErrors then | |
d189ec0e | 57 | G |
a3698041 | 58 | else |
6ae327f8 | 59 | Tycheck.checkFile G (tInit ()) prog |
a3698041 AC |
60 | end |
61 | ||
d189ec0e | 62 | fun basis () = |
234b917a | 63 | let |
d189ec0e AC |
64 | val dir = Posix.FileSys.opendir Config.libRoot |
65 | ||
66 | fun loop files = | |
67 | case Posix.FileSys.readdir dir of | |
d612d62c AC |
68 | NONE => (Posix.FileSys.closedir dir; |
69 | files) | |
d189ec0e AC |
70 | | SOME fname => |
71 | if String.isSuffix ".dtl" fname then | |
d612d62c AC |
72 | loop (OS.Path.joinDirFile {dir = Config.libRoot, |
73 | file = fname} | |
d189ec0e AC |
74 | :: files) |
75 | else | |
76 | loop files | |
77 | ||
78 | val files = loop [] | |
79 | val files = Order.order files | |
80 | in | |
6ae327f8 AC |
81 | if !ErrorMsg.anyErrors then |
82 | Env.empty | |
83 | else | |
84 | foldl (fn (fname, G) => check' G fname) Env.empty files | |
d189ec0e AC |
85 | end |
86 | ||
87 | fun check fname = | |
88 | let | |
89 | val _ = ErrorMsg.reset () | |
12adf55a | 90 | val _ = Env.preTycheck () |
d189ec0e AC |
91 | |
92 | val b = basis () | |
234b917a AC |
93 | in |
94 | if !ErrorMsg.anyErrors then | |
d189ec0e | 95 | (b, NONE) |
234b917a AC |
96 | else |
97 | let | |
7f012ffd | 98 | val _ = ErrorMsg.reset () |
d189ec0e | 99 | val prog = Parse.parse fname |
234b917a | 100 | in |
492c1cff | 101 | if !ErrorMsg.anyErrors then |
d189ec0e | 102 | (Env.empty, NONE) |
492c1cff | 103 | else |
d189ec0e | 104 | let |
6ae327f8 | 105 | val G' = Tycheck.checkFile b (tInit ()) prog |
d189ec0e AC |
106 | in |
107 | (G', #3 prog) | |
108 | end | |
234b917a AC |
109 | end |
110 | end | |
111 | ||
d189ec0e | 112 | fun reduce fname = |
a3698041 | 113 | let |
d189ec0e | 114 | val (G, body) = check fname |
a3698041 AC |
115 | in |
116 | if !ErrorMsg.anyErrors then | |
d189ec0e | 117 | NONE |
a3698041 | 118 | else |
d189ec0e AC |
119 | case body of |
120 | SOME body => | |
121 | let | |
122 | val body' = Reduce.reduceExp G body | |
123 | in | |
124 | (*printd (PD.hovBox (PD.PPS.Rel 0, | |
125 | [PD.string "Result:", | |
126 | PD.space 1, | |
127 | p_exp body']))*) | |
128 | SOME body' | |
129 | end | |
130 | | _ => NONE | |
a3698041 AC |
131 | end |
132 | ||
d189ec0e AC |
133 | fun eval fname = |
134 | case reduce fname of | |
135 | (SOME body') => | |
136 | if !ErrorMsg.anyErrors then | |
137 | () | |
138 | else | |
8a7c40fa | 139 | Eval.exec (SM.map (fn f => f ()) (!defaultV)) body' |
d189ec0e AC |
140 | | NONE => () |
141 | ||
559e89e9 AC |
142 | val dispatcher : C.rw ZString.zstring' = ZString.dupML' Config.dispatcher |
143 | ||
144 | fun ssl_err s = | |
145 | let | |
146 | val err = F_OpenSSL_SML_get_error.f () | |
147 | in | |
148 | print s; | |
149 | print "\nReason: "; | |
150 | print (ZString.toML (F_OpenSSL_SML_lib_error_string.f err)); | |
151 | print ":"; | |
152 | print (ZString.toML (F_OpenSSL_SML_func_error_string.f err)); | |
153 | print ":"; | |
154 | print (ZString.toML (F_OpenSSL_SML_reason_error_string.f err)); | |
155 | print "\n" | |
156 | end | |
157 | ||
158 | exception OpenSSL of string | |
159 | ||
160 | fun writeAll (bio, s) = | |
161 | let | |
162 | val buf = ZString.dupML' s | |
163 | ||
164 | fun loop (buf, len) = | |
165 | let | |
166 | val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, len) | |
167 | in | |
168 | if r = len then | |
169 | () | |
170 | else if r <= 0 then | |
171 | (C.free' buf; | |
172 | raise OpenSSL "BIO_write failed") | |
173 | else | |
174 | loop (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), Int32.- (len, r)) | |
175 | end | |
176 | in | |
177 | loop (buf, Int32.fromInt (size s)); | |
178 | C.free' buf | |
179 | end | |
180 | ||
181 | fun request fname = | |
182 | let | |
183 | val bio = F_OpenSSL_SML_new_connect.f' dispatcher | |
184 | in | |
185 | if C.Ptr.isNull' bio then | |
186 | (ssl_err ("Error initializating connection to dispatcher at " ^ Config.dispatcher); | |
187 | F_OpenSSL_SML_free_all.f' bio) | |
188 | else if F_OpenSSL_SML_do_connect.f' bio <= 0 then | |
189 | (ssl_err ("Error connecting to dispatcher at " ^ Config.dispatcher); | |
190 | F_OpenSSL_SML_free_all.f' bio) | |
191 | else let | |
192 | val inf = TextIO.openIn fname | |
193 | ||
194 | fun loop () = | |
195 | case TextIO.inputLine inf of | |
196 | NONE => () | |
197 | | SOME line => (writeAll (bio, line); | |
198 | loop ()) | |
199 | in | |
200 | loop (); | |
201 | TextIO.closeIn inf; | |
202 | F_OpenSSL_SML_free_all.f' bio | |
203 | end | |
204 | end | |
205 | ||
234b917a | 206 | end |