730 val _ = if (case some_abs of NONE => true | SOME abs => not (c = abs)) |
730 val _ = if (case some_abs of NONE => true | SOME abs => not (c = abs)) |
731 andalso Code.is_abstr thy c |
731 andalso Code.is_abstr thy c |
732 then translation_error ctxt permissive some_thm deps |
732 then translation_error ctxt permissive some_thm deps |
733 "Abstraction violation" ("constant " ^ Code.string_of_const thy c) |
733 "Abstraction violation" ("constant " ^ Code.string_of_const thy c) |
734 else () |
734 else () |
735 in translate_const_proper ctxt algbr eqngr permissive some_thm (c, ty) (deps, program) end |
|
736 and translate_const_proper ctxt algbr eqngr permissive some_thm (c, ty) = |
|
737 let |
|
738 val thy = Proof_Context.theory_of ctxt; |
|
739 val (annotate, ty') = dest_tagged_type ty; |
735 val (annotate, ty') = dest_tagged_type ty; |
740 val typargs = Sign.const_typargs thy (c, ty'); |
736 val typargs = Sign.const_typargs thy (c, ty'); |
741 val sorts = Code_Preproc.sortargs eqngr c; |
737 val sorts = Code_Preproc.sortargs eqngr c; |
742 val (dom, range) = Term.strip_type ty'; |
738 val (dom, range) = Term.strip_type ty'; |
743 in |
739 in |
744 ensure_const ctxt algbr eqngr permissive c |
740 (deps, program) |
745 ##>> fold_map (translate_typ ctxt algbr eqngr permissive) typargs |
741 |> ensure_const ctxt algbr eqngr permissive c |
746 ##>> fold_map (translate_dicts ctxt algbr eqngr permissive some_thm) (typargs ~~ sorts) |
742 ||>> fold_map (translate_typ ctxt algbr eqngr permissive) typargs |
747 ##>> fold_map (translate_typ ctxt algbr eqngr permissive) (range :: dom) |
743 ||>> fold_map (translate_dicts ctxt algbr eqngr permissive some_thm) (typargs ~~ sorts) |
748 #>> (fn (((c, typargs), dss), range :: dom) => |
744 ||>> fold_map (translate_typ ctxt algbr eqngr permissive) (range :: dom) |
|
745 |>> (fn (((c, typargs), dss), range :: dom) => |
749 { sym = Constant c, typargs = typargs, dicts = dss, |
746 { sym = Constant c, typargs = typargs, dicts = dss, |
750 dom = dom, range = range, annotation = |
747 dom = dom, range = range, annotation = |
751 if annotate then SOME (dom `--> range) else NONE }) |
748 if annotate then SOME (dom `--> range) else NONE }) |
752 end |
749 end |
753 and translate_case ctxt algbr eqngr permissive some_thm (t_pos, []) _ (const as { dom, ... }, ts) = |
750 and translate_case ctxt algbr eqngr permissive some_thm (t_pos, []) _ (const as { dom, ... }, ts) = |
768 fun project_cases xs = |
765 fun project_cases xs = |
769 xs |
766 xs |
770 |> nth_drop t_pos |
767 |> nth_drop t_pos |
771 |> curry (op ~~) case_pats |
768 |> curry (op ~~) case_pats |
772 |> map_filter (fn (NONE, _) => NONE | (SOME _, x) => SOME x); |
769 |> map_filter (fn (NONE, _) => NONE | (SOME _, x) => SOME x); |
773 val tys = take (length case_pats + 1) (binder_types (snd (dest_tagged_type ty))); |
770 val tys = take (length case_pats + 1) (binder_types ty); |
774 val ty_case = project_term tys; |
771 val ty_case = project_term tys; |
775 val ty_case' = project_term dom; |
772 val ty_case' = project_term dom; |
776 val constrs = map_filter I case_pats ~~ project_cases tys |
773 val constrs = map_filter I case_pats ~~ project_cases tys |
777 |> map (fn ((c, n), ty) => |
774 |> map (fn ((c, n), ty) => |
778 ((c, (take n o binder_types) ty ---> ty_case), n)); |
775 ((c, (take n o binder_types) ty ---> ty_case), n)); |
787 #>> (fn constrs => |
784 #>> (fn constrs => |
788 ICase { term = project_term ts, typ = ty_case', |
785 ICase { term = project_term ts, typ = ty_case', |
789 clauses = (filter_out (is_undefined_clause ctxt) o distill_clauses constrs o project_cases) ts, |
786 clauses = (filter_out (is_undefined_clause ctxt) o distill_clauses constrs o project_cases) ts, |
790 primitive = IConst const `$$ ts }) |
787 primitive = IConst const `$$ ts }) |
791 end |
788 end |
792 and translate_app_case ctxt algbr eqngr permissive some_thm pattern_schema ty const ((vs_tys, (ts1, rty)), ts2) = |
|
793 translate_case ctxt algbr eqngr permissive some_thm pattern_schema ty (const, ts1) |
|
794 #>> (fn t => (vs_tys `|==> (t, rty)) `$$ ts2) |
|
795 and translate_app ctxt algbr eqngr permissive some_thm some_abs (c_ty as (c, ty), ts) = |
789 and translate_app ctxt algbr eqngr permissive some_thm some_abs (c_ty as (c, ty), ts) = |
796 case Code.get_case_schema (Proof_Context.theory_of ctxt) c of |
790 translate_const ctxt algbr eqngr permissive some_thm some_abs c_ty |
797 SOME (wanted, pattern_schema) => |
791 ##>> fold_map (translate_term ctxt algbr eqngr permissive some_thm NONE) ts |
798 translate_const ctxt algbr eqngr permissive some_thm some_abs c_ty |
792 #-> (fn (const, ts) => case Code.get_case_schema (Proof_Context.theory_of ctxt) c of |
799 ##>> fold_map (translate_term ctxt algbr eqngr permissive some_thm NONE) ts |
793 SOME (wanted, pattern_schema) => |
800 #-> (fn (const, ts) => translate_app_case ctxt algbr eqngr permissive some_thm pattern_schema |
794 let |
801 ty const (satisfied_application wanted (const, ts))) |
795 val ((vs_tys, (ts1, rty)), ts2) = satisfied_application wanted (const, ts); |
802 | NONE => |
796 val (_, ty') = dest_tagged_type ty; |
803 translate_const ctxt algbr eqngr permissive some_thm some_abs c_ty |
797 in |
804 ##>> fold_map (translate_term ctxt algbr eqngr permissive some_thm NONE) ts |
798 translate_case ctxt algbr eqngr permissive some_thm pattern_schema ty' (const, ts1) |
805 #>> (fn (const, ts) => IConst const `$$ ts) |
799 #>> (fn t => (vs_tys `|==> (t, rty)) `$$ ts2) |
|
800 end |
|
801 | NONE => |
|
802 pair (IConst const `$$ ts)) |
806 and translate_tyvar_sort ctxt (algbr as (proj_sort, _)) eqngr permissive (v, sort) = |
803 and translate_tyvar_sort ctxt (algbr as (proj_sort, _)) eqngr permissive (v, sort) = |
807 fold_map (ensure_class ctxt algbr eqngr permissive) (proj_sort sort) |
804 fold_map (ensure_class ctxt algbr eqngr permissive) (proj_sort sort) |
808 #>> (fn sort => (unprefix "'" v, sort)) |
805 #>> (fn sort => (unprefix "'" v, sort)) |
809 and translate_dicts ctxt algbr eqngr permissive some_thm (ty, sort) = |
806 and translate_dicts ctxt algbr eqngr permissive some_thm (ty, sort) = |
810 let |
807 let |