361 |
361 |
362 (** translation kernel **) |
362 (** translation kernel **) |
363 |
363 |
364 (* generic mechanisms *) |
364 (* generic mechanisms *) |
365 |
365 |
366 fun ensure_stmt symbolize generate x (dep, program) = |
366 fun ensure_stmt symbolize generate x (deps, program) = |
367 let |
367 let |
368 val sym = symbolize x; |
368 val sym = symbolize x; |
369 val add_dep = case dep of NONE => I |
369 val add_dep = case deps of [] => I |
370 | SOME dep => Code_Symbol.Graph.add_edge (dep, sym); |
370 | dep :: _ => Code_Symbol.Graph.add_edge (dep, sym); |
371 in |
371 in |
372 if can (Code_Symbol.Graph.get_node program) sym |
372 if can (Code_Symbol.Graph.get_node program) sym |
373 then |
373 then |
374 program |
374 program |
375 |> add_dep |
375 |> add_dep |
376 |> pair dep |
376 |> pair deps |
377 |> pair x |
377 |> pair x |
378 else |
378 else |
379 program |
379 program |
380 |> Code_Symbol.Graph.default_node (sym, NoStmt) |
380 |> Code_Symbol.Graph.default_node (sym, NoStmt) |
381 |> add_dep |
381 |> add_dep |
382 |> curry generate (SOME sym) |
382 |> curry generate (sym :: deps) |
383 ||> snd |
383 ||> snd |
384 |-> (fn stmt => (Code_Symbol.Graph.map_node sym) (K stmt)) |
384 |-> (fn stmt => (Code_Symbol.Graph.map_node sym) (K stmt)) |
385 |> pair dep |
385 |> pair deps |
386 |> pair x |
386 |> pair x |
387 end; |
387 end; |
388 |
388 |
389 exception PERMISSIVE of unit; |
389 exception PERMISSIVE of unit; |
390 |
390 |
391 fun translation_error thy permissive some_thm msg sub_msg = |
391 fun translation_error thy program permissive some_thm deps msg sub_msg = |
392 if permissive |
392 if permissive |
393 then raise PERMISSIVE () |
393 then raise PERMISSIVE () |
394 else |
394 else |
395 let |
395 let |
396 val err_thm = |
396 val ctxt = Proof_Context.init_global thy; |
397 (case some_thm of |
397 val thm_msg = |
398 SOME thm => "\n(in code equation " ^ Display.string_of_thm_global thy thm ^ ")" |
398 Option.map (fn thm => "in code equation " ^ Display.string_of_thm ctxt thm) some_thm; |
399 | NONE => ""); |
399 val dep_msg = if null (tl deps) then NONE |
400 in error (msg ^ err_thm ^ ":\n" ^ sub_msg) end; |
400 else SOME ("with dependency " |
|
401 ^ space_implode " -> " (map (Code_Symbol.quote ctxt) (rev deps))); |
|
402 val thm_dep_msg = case (thm_msg, dep_msg) |
|
403 of (SOME thm_msg, SOME dep_msg) => "\n(" ^ thm_msg ^ ",\n" ^ dep_msg ^ ")" |
|
404 | (SOME thm_msg, NONE) => "\n(" ^ thm_msg ^ ")" |
|
405 | (NONE, SOME dep_msg) => "\n(" ^ dep_msg ^ ")" |
|
406 | (NONE, NONE) => "" |
|
407 in error (msg ^ thm_dep_msg ^ ":\n" ^ sub_msg) end; |
401 |
408 |
402 fun maybe_permissive f prgrm = |
409 fun maybe_permissive f prgrm = |
403 f prgrm |>> SOME handle PERMISSIVE () => (NONE, prgrm); |
410 f prgrm |>> SOME handle PERMISSIVE () => (NONE, prgrm); |
404 |
411 |
405 fun not_wellsorted thy permissive some_thm ty sort e = |
412 fun not_wellsorted thy program permissive some_thm deps ty sort e = |
406 let |
413 let |
407 val err_class = Sorts.class_error (Context.pretty_global thy) e; |
414 val err_class = Sorts.class_error (Context.pretty_global thy) e; |
408 val err_typ = |
415 val err_typ = |
409 "Type " ^ Syntax.string_of_typ_global thy ty ^ " not of sort " ^ |
416 "Type " ^ Syntax.string_of_typ_global thy ty ^ " not of sort " ^ |
410 Syntax.string_of_sort_global thy sort; |
417 Syntax.string_of_sort_global thy sort; |
411 in |
418 in |
412 translation_error thy permissive some_thm "Wellsortedness error" |
419 translation_error thy program permissive some_thm deps |
413 (err_typ ^ "\n" ^ err_class) |
420 "Wellsortedness error" (err_typ ^ "\n" ^ err_class) |
414 end; |
421 end; |
415 |
422 |
416 |
423 |
417 (* inference of type annotations for disambiguation with type classes *) |
424 (* inference of type annotations for disambiguation with type classes *) |
418 |
425 |
461 Weakening of (class * class) list * plain_typarg_witness |
468 Weakening of (class * class) list * plain_typarg_witness |
462 and plain_typarg_witness = |
469 and plain_typarg_witness = |
463 Global of (string * class) * typarg_witness list list |
470 Global of (string * class) * typarg_witness list list |
464 | Local of string * (int * sort); |
471 | Local of string * (int * sort); |
465 |
472 |
466 fun construct_dictionaries thy (proj_sort, algebra) permissive some_thm (ty, sort) (dep, program) = |
473 fun construct_dictionaries thy (proj_sort, algebra) permissive some_thm (ty, sort) (deps, program) = |
467 let |
474 let |
468 fun class_relation ((Weakening (classrels, x)), sub_class) super_class = |
475 fun class_relation ((Weakening (classrels, x)), sub_class) super_class = |
469 Weakening ((sub_class, super_class) :: classrels, x); |
476 Weakening ((sub_class, super_class) :: classrels, x); |
470 fun type_constructor (tyco, _) dss class = |
477 fun type_constructor (tyco, _) dss class = |
471 Weakening ([], Global ((tyco, class), (map o map) fst dss)); |
478 Weakening ([], Global ((tyco, class), (map o map) fst dss)); |
475 in map_index (fn (n, class) => (Weakening ([], Local (v, (n, sort'))), class)) sort' end; |
482 in map_index (fn (n, class) => (Weakening ([], Local (v, (n, sort'))), class)) sort' end; |
476 val typarg_witnesses = Sorts.of_sort_derivation algebra |
483 val typarg_witnesses = Sorts.of_sort_derivation algebra |
477 {class_relation = K (Sorts.classrel_derivation algebra class_relation), |
484 {class_relation = K (Sorts.classrel_derivation algebra class_relation), |
478 type_constructor = type_constructor, |
485 type_constructor = type_constructor, |
479 type_variable = type_variable} (ty, proj_sort sort) |
486 type_variable = type_variable} (ty, proj_sort sort) |
480 handle Sorts.CLASS_ERROR e => not_wellsorted thy permissive some_thm ty sort e; |
487 handle Sorts.CLASS_ERROR e => not_wellsorted thy program permissive some_thm deps ty sort e; |
481 in (typarg_witnesses, (dep, program)) end; |
488 in (typarg_witnesses, (deps, program)) end; |
482 |
489 |
483 |
490 |
484 (* translation *) |
491 (* translation *) |
485 |
492 |
486 fun ensure_tyco thy algbr eqngr permissive tyco = |
493 fun ensure_tyco thy algbr eqngr permissive tyco = |
613 fold_map (translate_term thy algbr eqngr permissive some_thm) args |
620 fold_map (translate_term thy algbr eqngr permissive some_thm) args |
614 ##>> translate_term thy algbr eqngr permissive some_thm (rhs, some_abs) |
621 ##>> translate_term thy algbr eqngr permissive some_thm (rhs, some_abs) |
615 #>> rpair (some_thm, proper) |
622 #>> rpair (some_thm, proper) |
616 and translate_eqns thy algbr eqngr permissive eqns = |
623 and translate_eqns thy algbr eqngr permissive eqns = |
617 maybe_permissive (fold_map (translate_eqn thy algbr eqngr permissive) eqns) |
624 maybe_permissive (fold_map (translate_eqn thy algbr eqngr permissive) eqns) |
618 and translate_const thy algbr eqngr permissive some_thm ((c, ty), some_abs) = |
625 and translate_const thy algbr eqngr permissive some_thm ((c, ty), some_abs) (deps, program) = |
619 let |
626 let |
620 val _ = if (case some_abs of NONE => true | SOME abs => not (c = abs)) |
627 val _ = if (case some_abs of NONE => true | SOME abs => not (c = abs)) |
621 andalso Code.is_abstr thy c |
628 andalso Code.is_abstr thy c |
622 then translation_error thy permissive some_thm |
629 then translation_error thy program permissive some_thm deps |
623 "Abstraction violation" ("constant " ^ Code.string_of_const thy c) |
630 "Abstraction violation" ("constant " ^ Code.string_of_const thy c) |
624 else () |
631 else () |
|
632 in translate_const_proper thy algbr eqngr permissive some_thm (c, ty) (deps, program) end |
|
633 and translate_const_proper thy algbr eqngr permissive some_thm (c, ty) = |
|
634 let |
625 val (annotate, ty') = dest_tagged_type ty; |
635 val (annotate, ty') = dest_tagged_type ty; |
626 val typargs = Sign.const_typargs thy (c, ty'); |
636 val typargs = Sign.const_typargs thy (c, ty'); |
627 val sorts = Code_Preproc.sortargs eqngr c; |
637 val sorts = Code_Preproc.sortargs eqngr c; |
628 val (dom, range) = Term.strip_type ty'; |
638 val (dom, range) = Term.strip_type ty'; |
629 in |
639 in |
717 of SOME case_scheme => translate_app_case thy algbr eqngr permissive some_thm case_scheme c_ty_ts |
727 of SOME case_scheme => translate_app_case thy algbr eqngr permissive some_thm case_scheme c_ty_ts |
718 | NONE => translate_app_const thy algbr eqngr permissive some_thm (c_ty_ts, some_abs) |
728 | NONE => translate_app_const thy algbr eqngr permissive some_thm (c_ty_ts, some_abs) |
719 and translate_tyvar_sort thy (algbr as (proj_sort, _)) eqngr permissive (v, sort) = |
729 and translate_tyvar_sort thy (algbr as (proj_sort, _)) eqngr permissive (v, sort) = |
720 fold_map (ensure_class thy algbr eqngr permissive) (proj_sort sort) |
730 fold_map (ensure_class thy algbr eqngr permissive) (proj_sort sort) |
721 #>> (fn sort => (unprefix "'" v, sort)) |
731 #>> (fn sort => (unprefix "'" v, sort)) |
722 and translate_dicts thy (algbr as (proj_sort, algebra)) eqngr permissive some_thm (ty, sort) = |
732 and translate_dicts thy algbr eqngr permissive some_thm (ty, sort) = |
723 let |
733 let |
724 fun mk_dict (Weakening (classrels, x)) = |
734 fun mk_dict (Weakening (classrels, x)) = |
725 fold_map (ensure_classrel thy algbr eqngr permissive) classrels |
735 fold_map (ensure_classrel thy algbr eqngr permissive) classrels |
726 ##>> mk_plain_dict x |
736 ##>> mk_plain_dict x |
727 #>> Dict |
737 #>> Dict |
745 val empty = Code_Symbol.Graph.empty; |
755 val empty = Code_Symbol.Graph.empty; |
746 ); |
756 ); |
747 |
757 |
748 fun invoke_generation ignore_cache thy (algebra, eqngr) generate thing = |
758 fun invoke_generation ignore_cache thy (algebra, eqngr) generate thing = |
749 Program.change_yield (if ignore_cache then NONE else SOME thy) |
759 Program.change_yield (if ignore_cache then NONE else SOME thy) |
750 (fn program => (NONE, program) |
760 (fn program => ([], program) |
751 |> generate thy algebra eqngr thing |
761 |> generate thy algebra eqngr thing |
752 |-> (fn thing => fn (_, program) => (thing, program))); |
762 |-> (fn thing => fn (_, program) => (thing, program))); |
753 |
763 |
754 |
764 |
755 (* program generation *) |
765 (* program generation *) |
790 fold_map (translate_tyvar_sort thy algbr eqngr false) vs |
800 fold_map (translate_tyvar_sort thy algbr eqngr false) vs |
791 ##>> translate_typ thy algbr eqngr false ty |
801 ##>> translate_typ thy algbr eqngr false ty |
792 ##>> translate_term thy algbr eqngr false NONE (t', NONE) |
802 ##>> translate_term thy algbr eqngr false NONE (t', NONE) |
793 #>> (fn ((vs, ty), t) => Fun |
803 #>> (fn ((vs, ty), t) => Fun |
794 (((vs, ty), [(([], t), (NONE, true))]), NONE)); |
804 (((vs, ty), [(([], t), (NONE, true))]), NONE)); |
795 fun term_value (dep, program1) = |
805 fun term_value (deps, program1) = |
796 let |
806 let |
797 val Fun ((vs_ty, [(([], t), _)]), _) = |
807 val Fun ((vs_ty, [(([], t), _)]), _) = |
798 Code_Symbol.Graph.get_node program1 dummy_constant; |
808 Code_Symbol.Graph.get_node program1 dummy_constant; |
799 val deps = Code_Symbol.Graph.immediate_succs program1 dummy_constant; |
809 val deps' = Code_Symbol.Graph.immediate_succs program1 dummy_constant; |
800 val program2 = Code_Symbol.Graph.del_node dummy_constant program1; |
810 val program2 = Code_Symbol.Graph.del_node dummy_constant program1; |
801 val deps_all = Code_Symbol.Graph.all_succs program2 deps; |
811 val deps_all = Code_Symbol.Graph.all_succs program2 deps'; |
802 val program3 = Code_Symbol.Graph.restrict (member (op =) deps_all) program2; |
812 val program3 = Code_Symbol.Graph.restrict (member (op =) deps_all) program2; |
803 in ((program3, ((vs_ty, t), deps)), (dep, program2)) end; |
813 in ((program3, ((vs_ty, t), deps')), (deps, program2)) end; |
804 in |
814 in |
805 ensure_stmt Constant stmt_value @{const_name dummy_pattern} |
815 ensure_stmt Constant stmt_value @{const_name dummy_pattern} |
806 #> snd |
816 #> snd |
807 #> term_value |
817 #> term_value |
808 end; |
818 end; |
823 Code_Preproc.dynamic_value thy postproc (dynamic_evaluator thy evaluator); |
833 Code_Preproc.dynamic_value thy postproc (dynamic_evaluator thy evaluator); |
824 |
834 |
825 fun lift_evaluation thy evaluation' algebra eqngr program vs t = |
835 fun lift_evaluation thy evaluation' algebra eqngr program vs t = |
826 let |
836 let |
827 val ((_, (((vs', ty'), t'), deps)), _) = |
837 val ((_, (((vs', ty'), t'), deps)), _) = |
828 ensure_value thy algebra eqngr t (NONE, program); |
838 ensure_value thy algebra eqngr t ([], program); |
829 in evaluation' ((original_sorts vs vs', (vs', ty')), t') deps end; |
839 in evaluation' ((original_sorts vs vs', (vs', ty')), t') deps end; |
830 |
840 |
831 fun lift_evaluator thy evaluator' consts algebra eqngr = |
841 fun lift_evaluator thy evaluator' consts algebra eqngr = |
832 let |
842 let |
833 fun generate_consts thy algebra eqngr = |
843 fun generate_consts thy algebra eqngr = |