src/Pure/Syntax/syn_trans.ML
changeset 3777 434d875f4661
parent 3700 3a8192e83579
child 3928 787d2659ce4a
equal deleted inserted replaced
3776:38f8ec304b95 3777:434d875f4661
    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 *)
   171     (strip_abss strip_abs_vars strip_abs_body (eta_contr tm));
   171     (strip_abss strip_abs_vars strip_abs_body (eta_contr tm));
   172 
   172 
   173 
   173 
   174 fun abs_ast_tr' (*"_abs"*) asts =
   174 fun abs_ast_tr' (*"_abs"*) asts =
   175   (case unfold_ast_p "_abs" (Appl (Constant "_abs" :: asts)) of
   175   (case unfold_ast_p "_abs" (Appl (Constant "_abs" :: asts)) of
   176     ([], _) => raise_ast "abs_ast_tr'" asts
   176     ([], _) => raise AST ("abs_ast_tr'", asts)
   177   | (xs, body) => Appl [Constant "_lambda", fold_ast "_pttrns" xs, body]);
   177   | (xs, body) => Appl [Constant "_lambda", fold_ast "_pttrns" xs, body]);
   178 
   178 
   179 
   179 
   180 (* binder *)
   180 (* binder *)
   181 
   181 
   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 =
   324       | term_of (Variable x) = scan_var x
   324       | term_of (Variable x) = scan_var x
   325       | term_of (Appl (Constant a :: (asts as _ :: _))) =
   325       | term_of (Appl (Constant a :: (asts as _ :: _))) =
   326           trans a (map term_of asts)
   326           trans a (map term_of asts)
   327       | term_of (Appl (ast :: (asts as _ :: _))) =
   327       | term_of (Appl (ast :: (asts as _ :: _))) =
   328           list_comb (term_of ast, map term_of asts)
   328           list_comb (term_of ast, map term_of asts)
   329       | term_of (ast as Appl _) = raise_ast "ast_to_term: malformed ast" [ast];
   329       | term_of (ast as Appl _) = raise AST ("ast_to_term: malformed ast", [ast]);
   330   in
   330   in
   331     term_of ast
   331     term_of ast
   332   end;
   332   end;
   333 
   333 
   334 end;
   334 end;