58 (* typ_of_term *) |
56 (* typ_of_term *) |
59 |
57 |
60 fun typ_of_term get_sort t = |
58 fun typ_of_term get_sort t = |
61 let |
59 let |
62 fun typ_of (Free (x, _)) = |
60 fun typ_of (Free (x, _)) = |
63 if is_tid x then TFree (x, get_sort (x, ~1)) |
61 if Lexicon.is_tid x then TFree (x, get_sort (x, ~1)) |
64 else Type (x, []) |
62 else Type (x, []) |
65 | typ_of (Var (xi, _)) = TVar (xi, get_sort xi) |
63 | typ_of (Var (xi, _)) = TVar (xi, get_sort xi) |
66 | typ_of (Const ("_ofsort", _) $ Free (x, _) $ _) = |
64 | typ_of (Const ("_ofsort", _) $ Free (x, _) $ _) = |
67 TFree (x, get_sort (x, ~1)) |
65 TFree (x, get_sort (x, ~1)) |
68 | typ_of (Const ("_ofsort", _) $ Var (xi, _) $ _) = |
66 | typ_of (Const ("_ofsort", _) $ Var (xi, _) $ _) = |
88 |
86 |
89 (* term_of_sort *) |
87 (* term_of_sort *) |
90 |
88 |
91 fun term_of_sort S = |
89 fun term_of_sort S = |
92 let |
90 let |
93 fun class c = const "_class" $ free c; |
91 fun class c = Lexicon.const "_class" $ Lexicon.free c; |
94 |
92 |
95 fun classes [] = sys_error "term_of_sort" |
93 fun classes [] = sys_error "term_of_sort" |
96 | classes [c] = class c |
94 | classes [c] = class c |
97 | classes (c :: cs) = const "_classes" $ class c $ classes cs; |
95 | classes (c :: cs) = Lexicon.const "_classes" $ class c $ classes cs; |
98 in |
96 in |
99 (case S of |
97 (case S of |
100 [] => const "_topsort" |
98 [] => Lexicon.const "_topsort" |
101 | [c] => class c |
99 | [c] => class c |
102 | cs => const "_sort" $ classes cs) |
100 | cs => Lexicon.const "_sort" $ classes cs) |
103 end; |
101 end; |
104 |
102 |
105 |
103 |
106 (* term_of_typ *) |
104 (* term_of_typ *) |
107 |
105 |
108 fun term_of_typ show_sorts ty = |
106 fun term_of_typ show_sorts ty = |
109 let |
107 let |
110 fun of_sort t S = |
108 fun of_sort t S = |
111 if show_sorts then const "_ofsort" $ t $ term_of_sort S |
109 if show_sorts then Lexicon.const "_ofsort" $ t $ term_of_sort S |
112 else t; |
110 else t; |
113 |
111 |
114 fun term_of (Type (a, Ts)) = list_comb (const a, map term_of Ts) |
112 fun term_of (Type (a, Ts)) = list_comb (Lexicon.const a, map term_of Ts) |
115 | term_of (TFree (x, S)) = of_sort (const "_tfree" $ free x) S |
113 | term_of (TFree (x, S)) = of_sort (Lexicon.const "_tfree" $ Lexicon.free x) S |
116 | term_of (TVar (xi, S)) = of_sort (const "_tvar" $ var xi) S; |
114 | term_of (TVar (xi, S)) = of_sort (Lexicon.const "_tvar" $ Lexicon.var xi) S; |
117 in |
115 in |
118 term_of ty |
116 term_of ty |
119 end; |
117 end; |
120 |
118 |
121 |
119 |
122 |
120 |
123 (** the type syntax **) |
121 (** the type syntax **) |
124 |
122 |
125 (* parse ast translations *) |
123 (* parse ast translations *) |
126 |
124 |
127 fun tapp_ast_tr (*"_tapp"*) [ty, f] = Appl [f, ty] |
125 fun tapp_ast_tr (*"_tapp"*) [ty, f] = Ast.Appl [f, ty] |
128 | tapp_ast_tr (*"_tapp"*) asts = raise AST ("tapp_ast_tr", asts); |
126 | tapp_ast_tr (*"_tapp"*) asts = raise Ast.AST ("tapp_ast_tr", asts); |
129 |
127 |
130 fun tappl_ast_tr (*"_tappl"*) [ty, tys, f] = |
128 fun tappl_ast_tr (*"_tappl"*) [ty, tys, f] = |
131 Appl (f :: ty :: unfold_ast "_types" tys) |
129 Ast.Appl (f :: ty :: Ast.unfold_ast "_types" tys) |
132 | tappl_ast_tr (*"_tappl"*) asts = raise AST ("tappl_ast_tr", asts); |
130 | tappl_ast_tr (*"_tappl"*) asts = raise Ast.AST ("tappl_ast_tr", asts); |
133 |
131 |
134 fun bracket_ast_tr (*"_bracket"*) [dom, cod] = |
132 fun bracket_ast_tr (*"_bracket"*) [dom, cod] = |
135 fold_ast_p "fun" (unfold_ast "_types" dom, cod) |
133 Ast.fold_ast_p "fun" (Ast.unfold_ast "_types" dom, cod) |
136 | bracket_ast_tr (*"_bracket"*) asts = raise AST ("bracket_ast_tr", asts); |
134 | bracket_ast_tr (*"_bracket"*) asts = raise Ast.AST ("bracket_ast_tr", asts); |
137 |
135 |
138 |
136 |
139 (* print ast translations *) |
137 (* print ast translations *) |
140 |
138 |
141 fun tappl_ast_tr' (f, []) = raise AST ("tappl_ast_tr'", [f]) |
139 fun tappl_ast_tr' (f, []) = raise Ast.AST ("tappl_ast_tr'", [f]) |
142 | tappl_ast_tr' (f, [ty]) = Appl [Constant "_tapp", ty, f] |
140 | tappl_ast_tr' (f, [ty]) = Ast.Appl [Ast.Constant "_tapp", ty, f] |
143 | tappl_ast_tr' (f, ty :: tys) = |
141 | tappl_ast_tr' (f, ty :: tys) = |
144 Appl [Constant "_tappl", ty, fold_ast "_types" tys, f]; |
142 Ast.Appl [Ast.Constant "_tappl", ty, Ast.fold_ast "_types" tys, f]; |
145 |
143 |
146 fun fun_ast_tr' (*"fun"*) asts = |
144 fun fun_ast_tr' (*"fun"*) asts = |
147 (case unfold_ast_p "fun" (Appl (Constant "fun" :: asts)) of |
145 (case Ast.unfold_ast_p "fun" (Ast.Appl (Ast.Constant "fun" :: asts)) of |
148 (dom as _ :: _ :: _, cod) |
146 (dom as _ :: _ :: _, cod) |
149 => Appl [Constant "_bracket", fold_ast "_types" dom, cod] |
147 => Ast.Appl [Ast.Constant "_bracket", Ast.fold_ast "_types" dom, cod] |
150 | _ => raise Match); |
148 | _ => raise Match); |
151 |
149 |
152 |
150 |
153 (* type_ext *) |
151 (* type_ext *) |
154 |
152 |
155 val sortT = Type ("sort", []); |
153 val sortT = Type ("sort", []); |
156 val classesT = Type ("classes", []); |
154 val classesT = Type ("classes", []); |
157 val typesT = Type ("types", []); |
155 val typesT = Type ("types", []); |
|
156 |
|
157 local open Lexicon SynExt in |
158 |
158 |
159 val type_ext = mk_syn_ext false [] |
159 val type_ext = mk_syn_ext false [] |
160 [Mfix ("_", tidT --> typeT, "", [], max_pri), |
160 [Mfix ("_", tidT --> typeT, "", [], max_pri), |
161 Mfix ("_", tvarT --> typeT, "", [], max_pri), |
161 Mfix ("_", tvarT --> typeT, "", [], max_pri), |
162 Mfix ("_", idT --> typeT, "", [], max_pri), |
162 Mfix ("_", idT --> typeT, "", [], max_pri), |