e680130a |
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. |
ae3a5b8c |
17 | *) |
e680130a |
18 | |
19 | (* Main interface *) |
20 | |
21 | structure Main :> MAIN = struct |
22 | |
add6f172 |
23 | open Ast Print |
e680130a |
24 | |
85af7d3e |
25 | structure SM = StringMap |
26 | |
e680130a |
27 | val dmy = ErrorMsg.dummyLoc |
28 | |
85af7d3e |
29 | val defaultT : record ref = ref SM.empty |
30 | val defaultV : exp SM.map ref = ref SM.empty |
31 | |
32 | fun registerDefault (name, t, v) = |
33 | case SM.find (!defaultT, name) of |
34 | NONE => (defaultT := SM.insert (!defaultT, name, t); |
35 | defaultV := SM.insert (!defaultV, name, v)) |
36 | | SOME _ => raise Fail "Duplicate default environment variable" |
37 | |
38 | fun tInit () = (TAction ((CRoot, dmy), |
39 | !defaultT, |
40 | StringMap.empty), |
41 | dmy) |
17ef447e |
42 | |
43 | |
e680130a |
44 | |
17ef447e |
45 | fun check' G fname = |
a11c0ff3 |
46 | let |
17ef447e |
47 | (*val _ = print ("Check " ^ fname ^ "\n")*) |
a11c0ff3 |
48 | val prog = Parse.parse fname |
49 | in |
50 | if !ErrorMsg.anyErrors then |
17ef447e |
51 | G |
a11c0ff3 |
52 | else |
85af7d3e |
53 | Tycheck.checkFile G (tInit ()) prog |
a11c0ff3 |
54 | end |
55 | |
17ef447e |
56 | fun basis () = |
e680130a |
57 | let |
17ef447e |
58 | val dir = Posix.FileSys.opendir Config.libRoot |
59 | |
60 | fun loop files = |
61 | case Posix.FileSys.readdir dir of |
c12828f2 |
62 | NONE => (Posix.FileSys.closedir dir; |
63 | files) |
17ef447e |
64 | | SOME fname => |
65 | if String.isSuffix ".dtl" fname then |
c12828f2 |
66 | loop (OS.Path.joinDirFile {dir = Config.libRoot, |
67 | file = fname} |
17ef447e |
68 | :: files) |
69 | else |
70 | loop files |
71 | |
72 | val files = loop [] |
73 | val files = Order.order files |
74 | in |
85af7d3e |
75 | if !ErrorMsg.anyErrors then |
76 | Env.empty |
77 | else |
78 | foldl (fn (fname, G) => check' G fname) Env.empty files |
17ef447e |
79 | end |
80 | |
81 | fun check fname = |
82 | let |
83 | val _ = ErrorMsg.reset () |
4e8a3f2b |
84 | val _ = Env.preTycheck () |
17ef447e |
85 | |
86 | val b = basis () |
e680130a |
87 | in |
88 | if !ErrorMsg.anyErrors then |
17ef447e |
89 | (b, NONE) |
e680130a |
90 | else |
91 | let |
17ef447e |
92 | val prog = Parse.parse fname |
e680130a |
93 | in |
add6f172 |
94 | if !ErrorMsg.anyErrors then |
17ef447e |
95 | (Env.empty, NONE) |
add6f172 |
96 | else |
17ef447e |
97 | let |
85af7d3e |
98 | val G' = Tycheck.checkFile b (tInit ()) prog |
17ef447e |
99 | in |
100 | (G', #3 prog) |
101 | end |
e680130a |
102 | end |
103 | end |
104 | |
17ef447e |
105 | fun reduce fname = |
a11c0ff3 |
106 | let |
17ef447e |
107 | val (G, body) = check fname |
a11c0ff3 |
108 | in |
109 | if !ErrorMsg.anyErrors then |
17ef447e |
110 | NONE |
a11c0ff3 |
111 | else |
17ef447e |
112 | case body of |
113 | SOME body => |
114 | let |
115 | val body' = Reduce.reduceExp G body |
116 | in |
117 | (*printd (PD.hovBox (PD.PPS.Rel 0, |
118 | [PD.string "Result:", |
119 | PD.space 1, |
120 | p_exp body']))*) |
121 | SOME body' |
122 | end |
123 | | _ => NONE |
a11c0ff3 |
124 | end |
125 | |
17ef447e |
126 | fun eval fname = |
127 | case reduce fname of |
128 | (SOME body') => |
129 | if !ErrorMsg.anyErrors then |
130 | () |
131 | else |
85af7d3e |
132 | Eval.exec (!defaultV) body' |
17ef447e |
133 | | NONE => () |
134 | |
e680130a |
135 | end |