18
|
1 |
(* Title: Pure/Syntax/type_ext.ML
|
0
|
2 |
ID: $Id$
|
|
3 |
Author: Tobias Nipkow and Markus Wenzel, TU Muenchen
|
|
4 |
|
18
|
5 |
The concrete syntax of types (used to bootstrap Pure).
|
|
6 |
|
|
7 |
TODO:
|
|
8 |
term_of_typ: prune sorts
|
0
|
9 |
*)
|
|
10 |
|
|
11 |
signature TYPE_EXT0 =
|
|
12 |
sig
|
|
13 |
val typ_of_term: (indexname -> sort) -> term -> typ
|
|
14 |
end;
|
|
15 |
|
|
16 |
signature TYPE_EXT =
|
|
17 |
sig
|
|
18 |
include TYPE_EXT0
|
239
|
19 |
structure SynExt: SYN_EXT
|
|
20 |
local open SynExt SynExt.Ast in
|
0
|
21 |
val term_of_typ: bool -> typ -> term
|
|
22 |
val tappl_ast_tr': ast * ast list -> ast
|
239
|
23 |
val type_ext: syn_ext
|
0
|
24 |
end
|
|
25 |
end;
|
|
26 |
|
239
|
27 |
functor TypeExtFun(structure Lexicon: LEXICON and SynExt: SYN_EXT): TYPE_EXT =
|
0
|
28 |
struct
|
|
29 |
|
239
|
30 |
structure SynExt = SynExt;
|
|
31 |
open Lexicon SynExt SynExt.Ast;
|
0
|
32 |
|
|
33 |
|
18
|
34 |
(** typ_of_term **)
|
0
|
35 |
|
|
36 |
fun typ_of_term def_sort t =
|
|
37 |
let
|
|
38 |
fun sort_err (xi as (x, i)) =
|
18
|
39 |
error ("Inconsistent sort constraints for type variable " ^
|
|
40 |
quote (if i < 0 then x else string_of_vname xi));
|
0
|
41 |
|
|
42 |
fun put_sort scs xi s =
|
|
43 |
(case assoc (scs, xi) of
|
|
44 |
None => (xi, s) :: scs
|
|
45 |
| Some s' => if s = s' then scs else sort_err xi);
|
|
46 |
|
18
|
47 |
fun insert x [] = [x: string]
|
|
48 |
| insert x (lst as y :: ys) =
|
|
49 |
if x > y then y :: insert x ys
|
|
50 |
else if x = y then lst
|
|
51 |
else x :: lst;
|
|
52 |
|
|
53 |
fun classes (Const (c, _)) = [c]
|
|
54 |
| classes (Free (c, _)) = [c]
|
|
55 |
| classes (Const ("_classes", _) $ Const (c, _) $ cls) =
|
|
56 |
insert c (classes cls)
|
|
57 |
| classes (Const ("_classes", _) $ Free (c, _) $ cls) =
|
|
58 |
insert c (classes cls)
|
|
59 |
| classes tm = raise_term "typ_of_term: bad encoding of classes" [tm];
|
0
|
60 |
|
|
61 |
fun sort (Const ("_emptysort", _)) = []
|
|
62 |
| sort (Const (s, _)) = [s]
|
|
63 |
| sort (Free (s, _)) = [s]
|
18
|
64 |
| sort (Const ("_sort", _) $ cls) = classes cls
|
|
65 |
| sort tm = raise_term "typ_of_term: bad encoding of sort" [tm];
|
0
|
66 |
|
|
67 |
fun typ (Free (x, _), scs) =
|
|
68 |
(if is_tfree x then TFree (x, []) else Type (x, []), scs)
|
|
69 |
| typ (Var (xi, _), scs) = (TVar (xi, []), scs)
|
|
70 |
| typ (Const ("_ofsort", _) $ Free (x, _) $ st, scs) =
|
|
71 |
(TFree (x, []), put_sort scs (x, ~1) (sort st))
|
|
72 |
| typ (Const ("_ofsort", _) $ Var (xi, _) $ st, scs) =
|
|
73 |
(TVar (xi, []), put_sort scs xi (sort st))
|
|
74 |
| typ (Const (a, _), scs) = (Type (a, []), scs)
|
18
|
75 |
| typ (tm as _ $ _, scs) =
|
0
|
76 |
let
|
|
77 |
val (t, ts) = strip_comb tm;
|
|
78 |
val a =
|
18
|
79 |
(case t of
|
0
|
80 |
Const (x, _) => x
|
|
81 |
| Free (x, _) => x
|
18
|
82 |
| _ => raise_term "typ_of_term: bad type application" [tm]);
|
0
|
83 |
val (tys, scs') = typs (ts, scs);
|
|
84 |
in
|
|
85 |
(Type (a, tys), scs')
|
|
86 |
end
|
18
|
87 |
| typ (tm, _) = raise_term "typ_of_term: bad encoding of typ" [tm]
|
0
|
88 |
and typs (t :: ts, scs) =
|
|
89 |
let
|
|
90 |
val (ty, scs') = typ (t, scs);
|
|
91 |
val (tys, scs'') = typs (ts, scs');
|
|
92 |
in (ty :: tys, scs'') end
|
|
93 |
| typs ([], scs) = ([], scs);
|
|
94 |
|
|
95 |
|
|
96 |
val (ty, scs) = typ (t, []);
|
|
97 |
|
|
98 |
fun get_sort xi =
|
|
99 |
(case assoc (scs, xi) of
|
|
100 |
None => def_sort xi
|
|
101 |
| Some s => s);
|
|
102 |
|
|
103 |
fun add_sorts (Type (a, tys)) = Type (a, map add_sorts tys)
|
|
104 |
| add_sorts (TVar (xi, _)) = TVar (xi, get_sort xi)
|
|
105 |
| add_sorts (TFree (x, _)) = TFree (x, get_sort (x, ~1));
|
|
106 |
in
|
|
107 |
add_sorts ty
|
|
108 |
end;
|
|
109 |
|
|
110 |
|
|
111 |
|
|
112 |
(** term_of_typ **)
|
|
113 |
|
|
114 |
fun term_of_typ show_sorts ty =
|
|
115 |
let
|
|
116 |
fun const x = Const (x, dummyT);
|
18
|
117 |
fun free x = Free (x, dummyT);
|
|
118 |
fun var xi = Var (xi, dummyT);
|
0
|
119 |
|
|
120 |
fun classes [] = raise Match
|
18
|
121 |
| classes [c] = free c
|
|
122 |
| classes (c :: cs) = const "_classes" $ free c $ classes cs;
|
0
|
123 |
|
|
124 |
fun sort [] = const "_emptysort"
|
18
|
125 |
| sort [s] = free s
|
|
126 |
| sort ss = const "_sort" $ classes ss;
|
0
|
127 |
|
|
128 |
fun of_sort t ss =
|
|
129 |
if show_sorts then const "_ofsort" $ t $ sort ss else t;
|
|
130 |
|
18
|
131 |
fun term_of (Type (a, tys)) = list_comb (const a, map term_of tys)
|
|
132 |
| term_of (TFree (x, ss)) = of_sort (free x) ss
|
|
133 |
| term_of (TVar (xi, ss)) = of_sort (var xi) ss;
|
0
|
134 |
in
|
18
|
135 |
term_of ty
|
0
|
136 |
end;
|
|
137 |
|
|
138 |
|
|
139 |
|
|
140 |
(** the type syntax **)
|
|
141 |
|
18
|
142 |
(* parse ast translations *)
|
0
|
143 |
|
18
|
144 |
fun tappl_ast_tr (*"_tapp(l)"*) [types, f] =
|
|
145 |
Appl (f :: unfold_ast "_types" types)
|
|
146 |
| tappl_ast_tr (*"_tapp(l)"*) asts = raise_ast "tappl_ast_tr" asts;
|
0
|
147 |
|
|
148 |
fun bracket_ast_tr (*"_bracket"*) [dom, cod] =
|
|
149 |
fold_ast_p "fun" (unfold_ast "_types" dom, cod)
|
|
150 |
| bracket_ast_tr (*"_bracket"*) asts = raise_ast "bracket_ast_tr" asts;
|
|
151 |
|
|
152 |
|
18
|
153 |
(* print ast translations *)
|
0
|
154 |
|
|
155 |
fun tappl_ast_tr' (f, []) = raise_ast "tappl_ast_tr'" [f]
|
|
156 |
| tappl_ast_tr' (f, [ty]) = Appl [Constant "_tapp", ty, f]
|
|
157 |
| tappl_ast_tr' (f, tys) = Appl [Constant "_tappl", fold_ast "_types" tys, f];
|
|
158 |
|
|
159 |
fun fun_ast_tr' (*"fun"*) asts =
|
|
160 |
(case unfold_ast_p "fun" (Appl (Constant "fun" :: asts)) of
|
18
|
161 |
(dom as _ :: _ :: _, cod)
|
0
|
162 |
=> Appl [Constant "_bracket", fold_ast "_types" dom, cod]
|
|
163 |
| _ => raise Match);
|
|
164 |
|
|
165 |
|
|
166 |
(* type_ext *)
|
|
167 |
|
|
168 |
val sortT = Type ("sort", []);
|
|
169 |
val classesT = Type ("classes", []);
|
|
170 |
val typesT = Type ("types", []);
|
|
171 |
|
239
|
172 |
val type_ext = syn_ext
|
|
173 |
[logic, "type"]
|
|
174 |
[Mfix ("_", tfreeT --> typeT, "", [], max_pri),
|
|
175 |
Mfix ("_", tvarT --> typeT, "", [], max_pri),
|
|
176 |
Mfix ("_", idT --> typeT, "", [], max_pri),
|
|
177 |
Mfix ("_::_", [tfreeT, sortT] ---> typeT, "_ofsort", [max_pri, 0], max_pri),
|
|
178 |
Mfix ("_::_", [tvarT, sortT] ---> typeT, "_ofsort", [max_pri, 0], max_pri),
|
|
179 |
Mfix ("_", idT --> sortT, "", [], max_pri),
|
|
180 |
Mfix ("{}", sortT, "_emptysort", [], max_pri),
|
|
181 |
Mfix ("{_}", classesT --> sortT, "_sort", [], max_pri),
|
|
182 |
Mfix ("_", idT --> classesT, "", [], max_pri),
|
|
183 |
Mfix ("_,_", [idT, classesT] ---> classesT, "_classes", [], max_pri),
|
|
184 |
Mfix ("_ _", [typeT, idT] ---> typeT, "_tapp", [max_pri, 0], max_pri), (* FIXME ambiguous *)
|
|
185 |
Mfix ("((1'(_'))_)", [typesT, idT] ---> typeT, "_tappl", [], max_pri), (* FIXME ambiguous *)
|
|
186 |
Mfix ("_", typeT --> typesT, "", [], max_pri),
|
|
187 |
Mfix ("_,/ _", [typeT, typesT] ---> typesT, "_types", [], max_pri),
|
|
188 |
Mfix ("(_/ => _)", [typeT, typeT] ---> typeT, "fun", [1, 0], 0),
|
|
189 |
Mfix ("([_]/ => _)", [typesT, typeT] ---> typeT, "_bracket", [0, 0], 0)]
|
258
|
190 |
[]
|
239
|
191 |
([("_tapp", tappl_ast_tr), ("_tappl", tappl_ast_tr), ("_bracket", bracket_ast_tr)],
|
|
192 |
[],
|
|
193 |
[],
|
|
194 |
[("fun", fun_ast_tr')])
|
|
195 |
([], []);
|
0
|
196 |
|
|
197 |
|
|
198 |
end;
|
|
199 |
|