author | wenzelm |
Fri, 10 Oct 1997 15:47:41 +0200 | |
changeset 3829 | d7333ef9e72c |
parent 3778 | b70c41bc7491 |
child 5690 | 4b056ee5435c |
permissions | -rw-r--r-- |
18 | 1 |
(* Title: Pure/Syntax/type_ext.ML |
0 | 2 |
ID: $Id$ |
3 |
Author: Tobias Nipkow and Markus Wenzel, TU Muenchen |
|
4 |
||
2584 | 5 |
Utilities for input and output of types. Also the concrete syntax of |
6 |
types, which is used to bootstrap Pure. |
|
0 | 7 |
*) |
8 |
||
9 |
signature TYPE_EXT0 = |
|
2584 | 10 |
sig |
3778 | 11 |
val raw_term_sorts: term -> (indexname * sort) list |
2584 | 12 |
val typ_of_term: (indexname -> sort) -> term -> typ |
13 |
end; |
|
0 | 14 |
|
15 |
signature TYPE_EXT = |
|
2584 | 16 |
sig |
0 | 17 |
include TYPE_EXT0 |
2584 | 18 |
val term_of_sort: sort -> term |
1511 | 19 |
val term_of_typ: bool -> typ -> term |
20 |
val tappl_ast_tr': Ast.ast * Ast.ast list -> Ast.ast |
|
21 |
val type_ext: SynExt.syn_ext |
|
2584 | 22 |
end; |
0 | 23 |
|
1511 | 24 |
structure TypeExt : TYPE_EXT = |
0 | 25 |
struct |
2584 | 26 |
|
1511 | 27 |
open Lexicon SynExt Ast; |
0 | 28 |
|
2584 | 29 |
|
30 |
(** input utils **) |
|
0 | 31 |
|
2584 | 32 |
(* raw_term_sorts *) |
33 |
||
3778 | 34 |
fun raw_term_sorts tm = |
557
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
35 |
let |
18 | 36 |
fun classes (Const (c, _)) = [c] |
37 |
| classes (Free (c, _)) = [c] |
|
3778 | 38 |
| classes (Const ("_classes", _) $ Const (c, _) $ cs) = c :: classes cs |
39 |
| classes (Const ("_classes", _) $ Free (c, _) $ cs) = c :: classes cs |
|
40 |
| classes tm = raise TERM ("raw_term_sorts: bad encoding of classes", [tm]); |
|
0 | 41 |
|
2584 | 42 |
fun sort (Const ("_topsort", _)) = [] |
43 |
| sort (Const (c, _)) = [c] |
|
44 |
| sort (Free (c, _)) = [c] |
|
3778 | 45 |
| sort (Const ("_sort", _) $ cs) = classes cs |
46 |
| sort tm = raise TERM ("raw_term_sorts: bad encoding of sort", [tm]); |
|
2584 | 47 |
|
3778 | 48 |
fun add_env (Const ("_ofsort", _) $ Free (x, _) $ cs) env = ((x, ~1), sort cs) ins env |
49 |
| add_env (Const ("_ofsort", _) $ Var (xi, _) $ cs) env = (xi, sort cs) ins env |
|
50 |
| add_env (Abs (_, _, t)) env = add_env t env |
|
51 |
| add_env (t1 $ t2) env = add_env t1 (add_env t2 env) |
|
52 |
| add_env t env = env; |
|
557
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
53 |
in |
3778 | 54 |
add_env tm [] |
557
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
55 |
end; |
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
56 |
|
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
57 |
|
2584 | 58 |
(* typ_of_term *) |
0 | 59 |
|
2584 | 60 |
fun typ_of_term get_sort t = |
557
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
61 |
let |
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
62 |
fun typ_of (Free (x, _)) = |
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
63 |
if is_tid x then TFree (x, get_sort (x, ~1)) |
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
64 |
else Type (x, []) |
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
65 |
| typ_of (Var (xi, _)) = TVar (xi, get_sort xi) |
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
66 |
| typ_of (Const ("_ofsort", _) $ Free (x, _) $ _) = |
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
67 |
TFree (x, get_sort (x, ~1)) |
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
68 |
| typ_of (Const ("_ofsort", _) $ Var (xi, _) $ _) = |
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
69 |
TVar (xi, get_sort xi) |
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
70 |
| typ_of tm = |
0 | 71 |
let |
72 |
val (t, ts) = strip_comb tm; |
|
73 |
val a = |
|
18 | 74 |
(case t of |
0 | 75 |
Const (x, _) => x |
76 |
| Free (x, _) => x |
|
3778 | 77 |
| _ => raise TERM ("typ_of_term: bad encoding of type", [tm])); |
0 | 78 |
in |
557
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
79 |
Type (a, map typ_of ts) |
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
80 |
end; |
0 | 81 |
in |
557
9d386e6c02b7
added raw_term_sorts and changed typ_of_term accordingly (part of fix
wenzelm
parents:
347
diff
changeset
|
82 |
typ_of t |
0 | 83 |
end; |
84 |
||
85 |
||
86 |
||
2584 | 87 |
(** output utils **) |
88 |
||
2699 | 89 |
(* term_of_sort *) |
2584 | 90 |
|
91 |
fun term_of_sort S = |
|
92 |
let |
|
2699 | 93 |
fun class c = const "_class" $ free c; |
2584 | 94 |
|
95 |
fun classes [] = sys_error "term_of_sort" |
|
96 |
| classes [c] = class c |
|
97 |
| classes (c :: cs) = const "_classes" $ class c $ classes cs; |
|
98 |
in |
|
99 |
(case S of |
|
100 |
[] => const "_topsort" |
|
101 |
| [c] => class c |
|
102 |
| cs => const "_sort" $ classes cs) |
|
103 |
end; |
|
104 |
||
105 |
||
106 |
(* term_of_typ *) |
|
0 | 107 |
|
108 |
fun term_of_typ show_sorts ty = |
|
109 |
let |
|
2584 | 110 |
fun of_sort t S = |
111 |
if show_sorts then const "_ofsort" $ t $ term_of_sort S |
|
112 |
else t; |
|
0 | 113 |
|
2699 | 114 |
fun term_of (Type (a, Ts)) = list_comb (const a, map term_of Ts) |
115 |
| term_of (TFree (x, S)) = of_sort (const "_tfree" $ free x) S |
|
116 |
| term_of (TVar (xi, S)) = of_sort (const "_tvar" $ var xi) S; |
|
0 | 117 |
in |
18 | 118 |
term_of ty |
0 | 119 |
end; |
120 |
||
121 |
||
122 |
||
123 |
(** the type syntax **) |
|
124 |
||
18 | 125 |
(* parse ast translations *) |
0 | 126 |
|
347
cd41a57221d0
changed translation of type applications according to new grammar;
wenzelm
parents:
330
diff
changeset
|
127 |
fun tapp_ast_tr (*"_tapp"*) [ty, f] = Appl [f, ty] |
3778 | 128 |
| tapp_ast_tr (*"_tapp"*) asts = raise AST ("tapp_ast_tr", asts); |
347
cd41a57221d0
changed translation of type applications according to new grammar;
wenzelm
parents:
330
diff
changeset
|
129 |
|
cd41a57221d0
changed translation of type applications according to new grammar;
wenzelm
parents:
330
diff
changeset
|
130 |
fun tappl_ast_tr (*"_tappl"*) [ty, tys, f] = |
cd41a57221d0
changed translation of type applications according to new grammar;
wenzelm
parents:
330
diff
changeset
|
131 |
Appl (f :: ty :: unfold_ast "_types" tys) |
3778 | 132 |
| tappl_ast_tr (*"_tappl"*) asts = raise AST ("tappl_ast_tr", asts); |
0 | 133 |
|
134 |
fun bracket_ast_tr (*"_bracket"*) [dom, cod] = |
|
135 |
fold_ast_p "fun" (unfold_ast "_types" dom, cod) |
|
3778 | 136 |
| bracket_ast_tr (*"_bracket"*) asts = raise AST ("bracket_ast_tr", asts); |
0 | 137 |
|
138 |
||
18 | 139 |
(* print ast translations *) |
0 | 140 |
|
3778 | 141 |
fun tappl_ast_tr' (f, []) = raise AST ("tappl_ast_tr'", [f]) |
0 | 142 |
| tappl_ast_tr' (f, [ty]) = Appl [Constant "_tapp", ty, f] |
347
cd41a57221d0
changed translation of type applications according to new grammar;
wenzelm
parents:
330
diff
changeset
|
143 |
| tappl_ast_tr' (f, ty :: tys) = |
cd41a57221d0
changed translation of type applications according to new grammar;
wenzelm
parents:
330
diff
changeset
|
144 |
Appl [Constant "_tappl", ty, fold_ast "_types" tys, f]; |
0 | 145 |
|
146 |
fun fun_ast_tr' (*"fun"*) asts = |
|
147 |
(case unfold_ast_p "fun" (Appl (Constant "fun" :: asts)) of |
|
18 | 148 |
(dom as _ :: _ :: _, cod) |
0 | 149 |
=> Appl [Constant "_bracket", fold_ast "_types" dom, cod] |
150 |
| _ => raise Match); |
|
151 |
||
152 |
||
153 |
(* type_ext *) |
|
154 |
||
155 |
val sortT = Type ("sort", []); |
|
156 |
val classesT = Type ("classes", []); |
|
157 |
val typesT = Type ("types", []); |
|
158 |
||
764
b60e77395d1a
changed Pure's grammar and the way types are converted to nonterminals
clasohm
parents:
640
diff
changeset
|
159 |
val type_ext = mk_syn_ext false [] |
347
cd41a57221d0
changed translation of type applications according to new grammar;
wenzelm
parents:
330
diff
changeset
|
160 |
[Mfix ("_", tidT --> typeT, "", [], max_pri), |
239 | 161 |
Mfix ("_", tvarT --> typeT, "", [], max_pri), |
162 |
Mfix ("_", idT --> typeT, "", [], max_pri), |
|
3829 | 163 |
Mfix ("_", longidT --> typeT, "", [], max_pri), |
330
2fda15dd1e0f
changed the way a grammar is generated to allow the new parser to work;
clasohm
parents:
258
diff
changeset
|
164 |
Mfix ("_::_", [tidT, sortT] ---> typeT, "_ofsort", [max_pri, 0], max_pri), |
239 | 165 |
Mfix ("_::_", [tvarT, sortT] ---> typeT, "_ofsort", [max_pri, 0], max_pri), |
166 |
Mfix ("_", idT --> sortT, "", [], max_pri), |
|
3829 | 167 |
Mfix ("_", longidT --> sortT, "", [], max_pri), |
2584 | 168 |
Mfix ("{}", sortT, "_topsort", [], max_pri), |
239 | 169 |
Mfix ("{_}", classesT --> sortT, "_sort", [], max_pri), |
170 |
Mfix ("_", idT --> classesT, "", [], max_pri), |
|
3829 | 171 |
Mfix ("_", longidT --> classesT, "", [], max_pri), |
239 | 172 |
Mfix ("_,_", [idT, classesT] ---> classesT, "_classes", [], max_pri), |
3829 | 173 |
Mfix ("_,_", [longidT, classesT] ---> classesT, "_classes", [], max_pri), |
330
2fda15dd1e0f
changed the way a grammar is generated to allow the new parser to work;
clasohm
parents:
258
diff
changeset
|
174 |
Mfix ("_ _", [typeT, idT] ---> typeT, "_tapp", [max_pri, 0], max_pri), |
3829 | 175 |
Mfix ("_ _", [typeT, longidT] ---> typeT, "_tapp", [max_pri, 0], max_pri), |
330
2fda15dd1e0f
changed the way a grammar is generated to allow the new parser to work;
clasohm
parents:
258
diff
changeset
|
176 |
Mfix ("((1'(_,/ _'))_)", [typeT, typesT, idT] ---> typeT, "_tappl", [], max_pri), |
3829 | 177 |
Mfix ("((1'(_,/ _'))_)", [typeT, typesT, longidT] ---> typeT, "_tappl", [], max_pri), |
239 | 178 |
Mfix ("_", typeT --> typesT, "", [], max_pri), |
179 |
Mfix ("_,/ _", [typeT, typesT] ---> typesT, "_types", [], max_pri), |
|
180 |
Mfix ("(_/ => _)", [typeT, typeT] ---> typeT, "fun", [1, 0], 0), |
|
624 | 181 |
Mfix ("([_]/ => _)", [typesT, typeT] ---> typeT, "_bracket", [0, 0], 0), |
2678 | 182 |
Mfix ("'(_')", typeT --> typeT, "", [0], max_pri), |
183 |
Mfix ("'_", typeT, "dummy", [], max_pri)] |
|
258 | 184 |
[] |
347
cd41a57221d0
changed translation of type applications according to new grammar;
wenzelm
parents:
330
diff
changeset
|
185 |
([("_tapp", tapp_ast_tr), ("_tappl", tappl_ast_tr), ("_bracket", bracket_ast_tr)], |
239 | 186 |
[], |
187 |
[], |
|
188 |
[("fun", fun_ast_tr')]) |
|
2699 | 189 |
TokenTrans.token_translation |
239 | 190 |
([], []); |
0 | 191 |
|
192 |
end; |