48 (** parse (ast) translations **) |
48 (** parse (ast) translations **) |
49 |
49 |
50 (* application *) |
50 (* application *) |
51 |
51 |
52 fun appl_ast_tr [f, args] = Appl (f :: unfold_ast "_args" args) |
52 fun appl_ast_tr [f, args] = Appl (f :: unfold_ast "_args" args) |
53 | appl_ast_tr asts = raise_ast "appl_ast_tr" asts; |
53 | appl_ast_tr asts = raise AST ("appl_ast_tr", asts); |
54 |
54 |
55 fun applC_ast_tr [f, args] = Appl (f :: unfold_ast "_cargs" args) |
55 fun applC_ast_tr [f, args] = Appl (f :: unfold_ast "_cargs" args) |
56 | applC_ast_tr asts = raise_ast "applC_ast_tr" asts; |
56 | applC_ast_tr asts = raise AST ("applC_ast_tr", asts); |
57 |
57 |
58 |
58 |
59 (* abstraction *) |
59 (* abstraction *) |
60 |
60 |
61 fun idtyp_ast_tr (*"_idtyp"*) [x, ty] = Appl [Constant constrainC, x, ty] |
61 fun idtyp_ast_tr (*"_idtyp"*) [x, ty] = Appl [Constant constrainC, x, ty] |
62 | idtyp_ast_tr (*"_idtyp"*) asts = raise_ast "idtyp_ast_tr" asts; |
62 | idtyp_ast_tr (*"_idtyp"*) asts = raise AST ("idtyp_ast_tr", asts); |
63 |
63 |
64 fun lambda_ast_tr (*"_lambda"*) [pats, body] = |
64 fun lambda_ast_tr (*"_lambda"*) [pats, body] = |
65 fold_ast_p "_abs" (unfold_ast "_pttrns" pats, body) |
65 fold_ast_p "_abs" (unfold_ast "_pttrns" pats, body) |
66 | lambda_ast_tr (*"_lambda"*) asts = raise_ast "lambda_ast_tr" asts; |
66 | lambda_ast_tr (*"_lambda"*) asts = raise AST ("lambda_ast_tr", asts); |
67 |
67 |
68 val constrainAbsC = "_constrainAbs"; |
68 val constrainAbsC = "_constrainAbs"; |
69 |
69 |
70 fun abs_tr (*"_abs"*) [Free (x, T), body] = absfree (x, T, body) |
70 fun abs_tr (*"_abs"*) [Free (x, T), body] = absfree (x, T, body) |
71 | abs_tr (*"_abs"*) (ts as [Const (c, _) $ Free (x, T) $ tT, body]) = |
71 | abs_tr (*"_abs"*) (ts as [Const (c, _) $ Free (x, T) $ tT, body]) = |
72 if c = constrainC |
72 if c = constrainC |
73 then const constrainAbsC $ absfree (x, T, body) $ tT |
73 then const constrainAbsC $ absfree (x, T, body) $ tT |
74 else raise_term "abs_tr" ts |
74 else raise TERM ("abs_tr", ts) |
75 | abs_tr (*"_abs"*) ts = raise_term "abs_tr" ts; |
75 | abs_tr (*"_abs"*) ts = raise TERM ("abs_tr", ts); |
76 |
76 |
77 |
77 |
78 (* nondependent abstraction *) |
78 (* nondependent abstraction *) |
79 |
79 |
80 fun k_tr (*"_K"*) [t] = Abs ("uu", dummyT, incr_boundvars 1 t) |
80 fun k_tr (*"_K"*) [t] = Abs ("uu", dummyT, incr_boundvars 1 t) |
81 | k_tr (*"_K"*) ts = raise_term "k_tr" ts; |
81 | k_tr (*"_K"*) ts = raise TERM ("k_tr", ts); |
82 |
82 |
83 |
83 |
84 (* binder *) |
84 (* binder *) |
85 |
85 |
86 fun mk_binder_tr (sy, name) = |
86 fun mk_binder_tr (sy, name) = |
88 fun tr (Free (x, T), t) = const name $ absfree (x, T, t) |
88 fun tr (Free (x, T), t) = const name $ absfree (x, T, t) |
89 | tr (Const ("_idts", _) $ idt $ idts, t) = tr (idt, tr (idts, t)) |
89 | tr (Const ("_idts", _) $ idt $ idts, t) = tr (idt, tr (idts, t)) |
90 | tr (t1 as Const (c, _) $ Free (x, T) $ tT, t) = |
90 | tr (t1 as Const (c, _) $ Free (x, T) $ tT, t) = |
91 if c = constrainC then |
91 if c = constrainC then |
92 const name $ (const constrainAbsC $ absfree (x, T, t) $ tT) |
92 const name $ (const constrainAbsC $ absfree (x, T, t) $ tT) |
93 else raise_term "binder_tr" [t1, t] |
93 else raise TERM ("binder_tr", [t1, t]) |
94 | tr (t1, t2) = raise_term "binder_tr" [t1, t2]; |
94 | tr (t1, t2) = raise TERM ("binder_tr", [t1, t2]); |
95 |
95 |
96 fun binder_tr (*sy*) [idts, body] = tr (idts, body) |
96 fun binder_tr (*sy*) [idts, body] = tr (idts, body) |
97 | binder_tr (*sy*) ts = raise_term "binder_tr" ts; |
97 | binder_tr (*sy*) ts = raise TERM ("binder_tr", ts); |
98 in |
98 in |
99 (sy, binder_tr) |
99 (sy, binder_tr) |
100 end; |
100 end; |
101 |
101 |
102 |
102 |
103 (* meta propositions *) |
103 (* meta propositions *) |
104 |
104 |
105 fun aprop_tr (*"_aprop"*) [t] = const constrainC $ t $ const "prop" |
105 fun aprop_tr (*"_aprop"*) [t] = const constrainC $ t $ const "prop" |
106 | aprop_tr (*"_aprop"*) ts = raise_term "aprop_tr" ts; |
106 | aprop_tr (*"_aprop"*) ts = raise TERM ("aprop_tr", ts); |
107 |
107 |
108 fun ofclass_tr (*"_ofclass"*) [ty, cls] = |
108 fun ofclass_tr (*"_ofclass"*) [ty, cls] = |
109 cls $ (const constrainC $ const "TYPE" $ (const "itself" $ ty)) |
109 cls $ (const constrainC $ const "TYPE" $ (const "itself" $ ty)) |
110 | ofclass_tr (*"_ofclass"*) ts = raise_term "ofclass_tr" ts; |
110 | ofclass_tr (*"_ofclass"*) ts = raise TERM ("ofclass_tr", ts); |
111 |
111 |
112 |
112 |
113 (* meta implication *) |
113 (* meta implication *) |
114 |
114 |
115 fun bigimpl_ast_tr (*"_bigimpl"*) [asms, concl] = |
115 fun bigimpl_ast_tr (*"_bigimpl"*) [asms, concl] = |
116 fold_ast_p "==>" (unfold_ast "_asms" asms, concl) |
116 fold_ast_p "==>" (unfold_ast "_asms" asms, concl) |
117 | bigimpl_ast_tr (*"_bigimpl"*) asts = raise_ast "bigimpl_ast_tr" asts; |
117 | bigimpl_ast_tr (*"_bigimpl"*) asts = raise AST ("bigimpl_ast_tr", asts); |
118 |
118 |
119 |
119 |
120 |
120 |
121 (** print (ast) translations **) |
121 (** print (ast) translations **) |
122 |
122 |
123 (* application *) |
123 (* application *) |
124 |
124 |
125 fun appl_ast_tr' (f, []) = raise_ast "appl_ast_tr'" [f] |
125 fun appl_ast_tr' (f, []) = raise AST ("appl_ast_tr'", [f]) |
126 | appl_ast_tr' (f, args) = Appl [Constant "_appl", f, fold_ast "_args" args]; |
126 | appl_ast_tr' (f, args) = Appl [Constant "_appl", f, fold_ast "_args" args]; |
127 |
127 |
128 fun applC_ast_tr' (f, []) = raise_ast "applC_ast_tr'" [f] |
128 fun applC_ast_tr' (f, []) = raise AST ("applC_ast_tr'", [f]) |
129 | applC_ast_tr' (f, args) = |
129 | applC_ast_tr' (f, args) = |
130 Appl [Constant "_applC", f, fold_ast "_cargs" args]; |
130 Appl [Constant "_applC", f, fold_ast "_cargs" args]; |
131 |
131 |
132 |
132 |
133 (* abstraction *) |
133 (* abstraction *) |
238 end; |
238 end; |
239 |
239 |
240 |
240 |
241 fun mk_ofclass_tr' (*"_mk_ofclass"*) T [t] = |
241 fun mk_ofclass_tr' (*"_mk_ofclass"*) T [t] = |
242 const "_ofclass" $ term_of_typ false T $ t |
242 const "_ofclass" $ term_of_typ false T $ t |
243 | mk_ofclass_tr' (*"_mk_ofclass"*) T ts = raise_type "mk_ofclass_tr'" [T] ts; |
243 | mk_ofclass_tr' (*"_mk_ofclass"*) T ts = raise TYPE ("mk_ofclass_tr'", [T], ts); |
244 |
244 |
245 fun mk_ofclassS_tr' (*"_mk_ofclassS"*) T [t] = |
245 fun mk_ofclassS_tr' (*"_mk_ofclassS"*) T [t] = |
246 const "_ofclass" $ term_of_typ true T $ t |
246 const "_ofclass" $ term_of_typ true T $ t |
247 | mk_ofclassS_tr' (*"_mk_ofclassS"*) T ts = raise_type "mk_ofclassS_tr'" [T] ts; |
247 | mk_ofclassS_tr' (*"_mk_ofclassS"*) T ts = raise TYPE ("mk_ofclassS_tr'", [T], ts); |
248 |
248 |
249 |
249 |
250 (* meta implication *) |
250 (* meta implication *) |
251 |
251 |
252 fun impl_ast_tr' (*"==>"*) asts = |
252 fun impl_ast_tr' (*"==>"*) asts = |