123 fun binder_tr [idts, body] = tr (idts, body) |
123 fun binder_tr [idts, body] = tr (idts, body) |
124 | binder_tr ts = raise TERM ("binder_tr", ts); |
124 | binder_tr ts = raise TERM ("binder_tr", ts); |
125 in (syn, binder_tr) end; |
125 in (syn, binder_tr) end; |
126 |
126 |
127 |
127 |
|
128 (* type propositions *) |
|
129 |
|
130 fun mk_type ty = Lexicon.const "_constrain" $ Lexicon.const "TYPE" $ (Lexicon.const "itself" $ ty); |
|
131 |
|
132 fun ofclass_tr (*"_ofclass"*) [ty, cls] = cls $ mk_type ty |
|
133 | ofclass_tr (*"_ofclass"*) ts = raise TERM ("ofclass_tr", ts); |
|
134 |
|
135 fun sort_constraint_tr (*"_sort_constraint"*) [ty] = |
|
136 Lexicon.const "Pure.sort_constraint" $ mk_type ty |
|
137 | sort_constraint_tr (*"_sort_constraint"*) ts = raise TERM ("sort_constraint_tr", ts); |
|
138 |
|
139 |
128 (* meta propositions *) |
140 (* meta propositions *) |
129 |
141 |
130 fun aprop_tr (*"_aprop"*) [t] = Lexicon.const "_constrain" $ t $ Lexicon.const "prop" |
142 fun aprop_tr (*"_aprop"*) [t] = Lexicon.const "_constrain" $ t $ Lexicon.const "prop" |
131 | aprop_tr (*"_aprop"*) ts = raise TERM ("aprop_tr", ts); |
143 | aprop_tr (*"_aprop"*) ts = raise TERM ("aprop_tr", ts); |
132 |
|
133 fun ofclass_tr (*"_ofclass"*) [ty, cls] = |
|
134 cls $ (Lexicon.const "_constrain" $ Lexicon.const "TYPE" $ |
|
135 (Lexicon.const "itself" $ ty)) |
|
136 | ofclass_tr (*"_ofclass"*) ts = raise TERM ("ofclass_tr", ts); |
|
137 |
144 |
138 |
145 |
139 (* meta implication *) |
146 (* meta implication *) |
140 |
147 |
141 fun bigimpl_ast_tr (*"_bigimpl"*) (asts as [asms, concl]) = |
148 fun bigimpl_ast_tr (*"_bigimpl"*) (asts as [asms, concl]) = |
325 |
331 |
326 (* idtyp constraints *) |
332 (* idtyp constraints *) |
327 |
333 |
328 fun idtyp_ast_tr' a [Ast.Appl [Ast.Constant c, x, ty], xs] = |
334 fun idtyp_ast_tr' a [Ast.Appl [Ast.Constant c, x, ty], xs] = |
329 if c = "_constrain" then |
335 if c = "_constrain" then |
330 Ast.Appl [ Ast.Constant a, Ast.Appl [Ast.Constant "_idtyp", x, ty], xs] |
336 Ast.Appl [Ast.Constant a, Ast.Appl [Ast.Constant "_idtyp", x, ty], xs] |
331 else raise Match |
337 else raise Match |
332 | idtyp_ast_tr' _ _ = raise Match; |
338 | idtyp_ast_tr' _ _ = raise Match; |
|
339 |
|
340 |
|
341 (* type propositions *) |
|
342 |
|
343 fun type_prop_tr' _ (*"_type_prop"*) T [Const ("Pure.sort_constraint", _)] = |
|
344 Lexicon.const "_sort_constraint" $ TypeExt.term_of_typ true T |
|
345 | type_prop_tr' show_sorts (*"_type_prop"*) T [t] = |
|
346 Lexicon.const "_ofclass" $ TypeExt.term_of_typ show_sorts T $ t |
|
347 | type_prop_tr' _ (*"_type_prop"*) T ts = raise TYPE ("type_prop_tr'", [T], ts); |
333 |
348 |
334 |
349 |
335 (* meta propositions *) |
350 (* meta propositions *) |
336 |
351 |
337 fun prop_tr' tm = |
352 fun prop_tr' tm = |
353 if T = propT then aprop (Lexicon.var xi) else t |
368 if T = propT then aprop (Lexicon.var xi) else t |
354 | tr' Ts (t as Bound _) = |
369 | tr' Ts (t as Bound _) = |
355 if is_prop Ts t then aprop t else t |
370 if is_prop Ts t then aprop t else t |
356 | tr' Ts (Abs (x, T, t)) = Abs (x, T, tr' (T :: Ts) t) |
371 | tr' Ts (Abs (x, T, t)) = Abs (x, T, tr' (T :: Ts) t) |
357 | tr' Ts (t as t1 $ (t2 as Const ("TYPE", Type ("itself", [T])))) = |
372 | tr' Ts (t as t1 $ (t2 as Const ("TYPE", Type ("itself", [T])))) = |
358 if is_prop Ts t andalso not (is_term t) then Const ("_mk_ofclass", T) $ tr' Ts t1 |
373 if is_prop Ts t andalso not (is_term t) then Const ("_type_prop", T) $ tr' Ts t1 |
359 else tr' Ts t1 $ tr' Ts t2 |
374 else tr' Ts t1 $ tr' Ts t2 |
360 | tr' Ts (t as t1 $ t2) = |
375 | tr' Ts (t as t1 $ t2) = |
361 (if is_Const (Term.head_of t) orelse not (is_prop Ts t) |
376 (if is_Const (Term.head_of t) orelse not (is_prop Ts t) |
362 then I else aprop) (tr' Ts t1 $ tr' Ts t2); |
377 then I else aprop) (tr' Ts t1 $ tr' Ts t2); |
363 in tr' [] tm end; |
378 in tr' [] tm end; |
364 |
|
365 fun mk_ofclass_tr' show_sorts (*"_mk_ofclass"*) T [t] = |
|
366 Lexicon.const "_ofclass" $ TypeExt.term_of_typ show_sorts T $ t |
|
367 | mk_ofclass_tr' _ (*"_mk_ofclass"*) T ts = raise TYPE ("mk_ofclass_tr'", [T], ts); |
|
368 |
379 |
369 |
380 |
370 (* meta implication *) |
381 (* meta implication *) |
371 |
382 |
372 fun impl_ast_tr' (*"==>"*) asts = |
383 fun impl_ast_tr' (*"==>"*) asts = |
460 ([("_constify", constify_ast_tr), ("_appl", appl_ast_tr), ("_applC", applC_ast_tr), |
471 ([("_constify", constify_ast_tr), ("_appl", appl_ast_tr), ("_applC", applC_ast_tr), |
461 ("_lambda", lambda_ast_tr), ("_idtyp", idtyp_ast_tr), ("_idtypdummy", idtypdummy_ast_tr), |
472 ("_lambda", lambda_ast_tr), ("_idtyp", idtyp_ast_tr), ("_idtypdummy", idtypdummy_ast_tr), |
462 ("_bigimpl", bigimpl_ast_tr), ("_indexdefault", indexdefault_ast_tr), |
473 ("_bigimpl", bigimpl_ast_tr), ("_indexdefault", indexdefault_ast_tr), |
463 ("_indexnum", indexnum_ast_tr), ("_indexvar", indexvar_ast_tr), ("_struct", struct_ast_tr)], |
474 ("_indexnum", indexnum_ast_tr), ("_indexvar", indexvar_ast_tr), ("_struct", struct_ast_tr)], |
464 [("_abs", abs_tr), ("_aprop", aprop_tr), ("_ofclass", ofclass_tr), |
475 [("_abs", abs_tr), ("_aprop", aprop_tr), ("_ofclass", ofclass_tr), |
465 ("\\<^fixed>meta_conjunction", conjunction_tr), ("_TYPE", type_tr), |
476 ("_sort_constraint", sort_constraint_tr), ("\\<^fixed>meta_conjunction", conjunction_tr), |
466 ("\\<^fixed>meta_term", term_tr), ("_DDDOT", dddot_tr), ("_index", index_tr)], |
477 ("_TYPE", type_tr), ("\\<^fixed>meta_term", term_tr), ("_DDDOT", dddot_tr), |
|
478 ("_index", index_tr)], |
467 ([]: (string * (term list -> term)) list), |
479 ([]: (string * (term list -> term)) list), |
468 [("_abs", abs_ast_tr'), ("_idts", idtyp_ast_tr' "_idts"), |
480 [("_abs", abs_ast_tr'), ("_idts", idtyp_ast_tr' "_idts"), |
469 ("_pttrns", idtyp_ast_tr' "_pttrns"), ("==>", impl_ast_tr'), |
481 ("_pttrns", idtyp_ast_tr' "_pttrns"), ("==>", impl_ast_tr'), |
470 ("_index", index_ast_tr')]); |
482 ("_index", index_ast_tr')]); |
471 |
483 |
472 val pure_trfunsT = |
484 val pure_trfunsT = |
473 [("_mk_ofclass", mk_ofclass_tr'), ("TYPE", type_tr'), |
485 [("_type_prop", type_prop_tr'), ("TYPE", type_tr'), ("_type_constraint_", type_constraint_tr')]; |
474 ("_type_constraint_", type_constraint_tr')]; |
|
475 |
486 |
476 fun struct_trfuns structs = |
487 fun struct_trfuns structs = |
477 ([], [("_struct", struct_tr structs)], [], [("_struct", struct_ast_tr' structs)]); |
488 ([], [("_struct", struct_tr structs)], [], [("_struct", struct_ast_tr' structs)]); |
478 |
489 |
479 |
490 |