117 val polymorphism_of_type_sys : type_sys -> polymorphism |
117 val polymorphism_of_type_sys : type_sys -> polymorphism |
118 val level_of_type_sys : type_sys -> type_level |
118 val level_of_type_sys : type_sys -> type_level |
119 val is_type_sys_virtually_sound : type_sys -> bool |
119 val is_type_sys_virtually_sound : type_sys -> bool |
120 val is_type_sys_fairly_sound : type_sys -> bool |
120 val is_type_sys_fairly_sound : type_sys -> bool |
121 val choose_format : format list -> type_sys -> format * type_sys |
121 val choose_format : format list -> type_sys -> format * type_sys |
122 val raw_type_literals_for_types : typ list -> type_literal list |
|
123 val mk_aconns : |
122 val mk_aconns : |
124 connective -> ('a, 'b, 'c) formula list -> ('a, 'b, 'c) formula |
123 connective -> ('a, 'b, 'c) formula list -> ('a, 'b, 'c) formula |
125 val unmangled_const_name : string -> string |
124 val unmangled_const_name : string -> string |
126 val unmangled_const : string -> string * string fo_term list |
125 val unmangled_const : string -> string * string fo_term list |
127 val helper_table : ((string * bool) * thm list) list |
126 val helper_table : ((string * bool) * thm list) list |
391 TVarLit of name * name |
387 TVarLit of name * name |
392 |
388 |
393 fun gen_TVars 0 = [] |
389 fun gen_TVars 0 = [] |
394 | gen_TVars n = ("T_" ^ string_of_int n) :: gen_TVars (n-1) |
390 | gen_TVars n = ("T_" ^ string_of_int n) :: gen_TVars (n-1) |
395 |
391 |
396 fun pack_sort (_,[]) = [] |
392 val type_class = the_single @{sort type} |
397 | pack_sort (tvar, "HOL.type" :: srt) = |
393 |
398 pack_sort (tvar, srt) (* IGNORE sort "type" *) |
394 fun add_packed_sort tvar = |
399 | pack_sort (tvar, cls :: srt) = |
395 fold (fn s => s <> type_class ? cons (`make_type_class s, `I tvar)) |
400 (`make_type_class cls, `I tvar) :: pack_sort (tvar, srt) |
|
401 |
396 |
402 type arity_clause = |
397 type arity_clause = |
403 {name: string, |
398 {name: string, |
404 prem_lits: arity_literal list, |
399 prem_lits: arity_literal list, |
405 concl_lits: arity_literal} |
400 concl_lits: arity_literal} |
409 let |
404 let |
410 val tvars = gen_TVars (length args) |
405 val tvars = gen_TVars (length args) |
411 val tvars_srts = ListPair.zip (tvars, args) |
406 val tvars_srts = ListPair.zip (tvars, args) |
412 in |
407 in |
413 {name = name, |
408 {name = name, |
414 prem_lits = map TVarLit (union_all (map pack_sort tvars_srts)), |
409 prem_lits = [] |> fold (uncurry add_packed_sort) tvars_srts |> map TVarLit, |
415 concl_lits = TConsLit (`make_type_class cls, |
410 concl_lits = TConsLit (`make_type_class cls, |
416 `make_fixed_type_const tcons, |
411 `make_fixed_type_const tcons, |
417 tvars ~~ tvars)} |
412 tvars ~~ tvars)} |
418 end |
413 end |
419 |
414 |
445 in map try_classes tycons end |
440 in map try_classes tycons end |
446 |
441 |
447 (*Proving one (tycon, class) membership may require proving others, so iterate.*) |
442 (*Proving one (tycon, class) membership may require proving others, so iterate.*) |
448 fun iter_type_class_pairs _ _ [] = ([], []) |
443 fun iter_type_class_pairs _ _ [] = ([], []) |
449 | iter_type_class_pairs thy tycons classes = |
444 | iter_type_class_pairs thy tycons classes = |
450 let val cpairs = type_class_pairs thy tycons classes |
445 let |
451 val newclasses = union_all (union_all (union_all (map (map #2 o #2) cpairs))) |
446 fun maybe_insert_class s = |
452 |> subtract (op =) classes |> subtract (op =) HOLogic.typeS |
447 (s <> type_class andalso not (member (op =) classes s)) |
453 val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses |
448 ? insert (op =) s |
|
449 val cpairs = type_class_pairs thy tycons classes |
|
450 val newclasses = |
|
451 [] |> fold (fold (fold (fold maybe_insert_class) o snd) o snd) cpairs |
|
452 val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses |
454 in (union (op =) classes' classes, union (op =) cpairs' cpairs) end |
453 in (union (op =) classes' classes, union (op =) cpairs' cpairs) end |
455 |
454 |
456 fun make_arity_clauses thy tycons = |
455 fun make_arity_clauses thy tycons = |
457 iter_type_class_pairs thy tycons ##> multi_arity_clause |
456 iter_type_class_pairs thy tycons ##> multi_arity_clause |
458 |
457 |
682 Explicit_Type_Args false |
681 Explicit_Type_Args false |
683 else |
682 else |
684 general_type_arg_policy type_sys |
683 general_type_arg_policy type_sys |
685 |
684 |
686 (*Make literals for sorted type variables*) |
685 (*Make literals for sorted type variables*) |
687 fun generic_sorts_on_type (_, []) = [] |
686 fun generic_add_sorts_on_type (_, []) = I |
688 | generic_sorts_on_type ((x, i), s :: ss) = |
687 | generic_add_sorts_on_type ((x, i), s :: ss) = |
689 generic_sorts_on_type ((x, i), ss) |
688 generic_add_sorts_on_type ((x, i), ss) |
690 |> (if s = the_single @{sort HOL.type} then |
689 #> (if s = the_single @{sort HOL.type} then |
691 I |
690 I |
692 else if i = ~1 then |
691 else if i = ~1 then |
693 cons (TyLitFree (`make_type_class s, `make_fixed_type_var x)) |
692 insert (op =) (TyLitFree (`make_type_class s, `make_fixed_type_var x)) |
694 else |
693 else |
695 cons (TyLitVar (`make_type_class s, |
694 insert (op =) (TyLitVar (`make_type_class s, |
696 (make_schematic_type_var (x, i), x)))) |
695 (make_schematic_type_var (x, i), x)))) |
697 fun sorts_on_tfree (TFree (s, S)) = generic_sorts_on_type ((s, ~1), S) |
696 fun add_sorts_on_tfree (TFree (s, S)) = generic_add_sorts_on_type ((s, ~1), S) |
698 | sorts_on_tfree _ = [] |
697 | add_sorts_on_tfree _ = I |
699 fun sorts_on_tvar (TVar z) = generic_sorts_on_type z |
698 fun add_sorts_on_tvar (TVar z) = generic_add_sorts_on_type z |
700 | sorts_on_tvar _ = [] |
699 | add_sorts_on_tvar _ = I |
701 |
700 |
702 (* Given a list of sorted type variables, return a list of type literals. *) |
701 fun type_literals_for_types type_sys add_sorts_on_typ Ts = |
703 fun raw_type_literals_for_types Ts = |
702 [] |> level_of_type_sys type_sys <> No_Types ? fold add_sorts_on_typ Ts |
704 union_all (map sorts_on_tfree Ts @ map sorts_on_tvar Ts) |
|
705 |
|
706 fun type_literals_for_types type_sys sorts_on_typ Ts = |
|
707 if level_of_type_sys type_sys = No_Types then [] |
|
708 else union_all (map sorts_on_typ Ts) |
|
709 |
703 |
710 fun mk_aconns c phis = |
704 fun mk_aconns c phis = |
711 let val (phis', phi') = split_last phis in |
705 let val (phis', phi') = split_last phis in |
712 fold_rev (mk_aconn c) phis' phi' |
706 fold_rev (mk_aconn c) phis' phi' |
713 end |
707 end |
1527 | do_formula _ (AAtom tm) = AAtom (do_term tm) |
1521 | do_formula _ (AAtom tm) = AAtom (do_term tm) |
1528 in do_formula o SOME end |
1522 in do_formula o SOME end |
1529 |
1523 |
1530 fun bound_tvars type_sys Ts = |
1524 fun bound_tvars type_sys Ts = |
1531 mk_ahorn (map (formula_from_fo_literal o fo_literal_from_type_literal) |
1525 mk_ahorn (map (formula_from_fo_literal o fo_literal_from_type_literal) |
1532 (type_literals_for_types type_sys sorts_on_tvar Ts)) |
1526 (type_literals_for_types type_sys add_sorts_on_tvar Ts)) |
1533 |
1527 |
1534 fun formula_for_fact ctxt format nonmono_Ts type_sys |
1528 fun formula_for_fact ctxt format nonmono_Ts type_sys |
1535 ({combformula, atomic_types, ...} : translated_formula) = |
1529 ({combformula, atomic_types, ...} : translated_formula) = |
1536 combformula |
1530 combformula |
1537 |> close_combformula_universally |
1531 |> close_combformula_universally |
1589 (close_combformula_universally combformula) |
1583 (close_combformula_universally combformula) |
1590 |> bound_tvars type_sys atomic_types |
1584 |> bound_tvars type_sys atomic_types |
1591 |> close_formula_universally, NONE, NONE) |
1585 |> close_formula_universally, NONE, NONE) |
1592 |
1586 |
1593 fun free_type_literals type_sys ({atomic_types, ...} : translated_formula) = |
1587 fun free_type_literals type_sys ({atomic_types, ...} : translated_formula) = |
1594 atomic_types |> type_literals_for_types type_sys sorts_on_tfree |
1588 atomic_types |> type_literals_for_types type_sys add_sorts_on_tfree |
1595 |> map fo_literal_from_type_literal |
1589 |> map fo_literal_from_type_literal |
1596 |
1590 |
1597 fun formula_line_for_free_type j lit = |
1591 fun formula_line_for_free_type j lit = |
1598 Formula (tfree_clause_prefix ^ string_of_int j, Hypothesis, |
1592 Formula (tfree_clause_prefix ^ string_of_int j, Hypothesis, |
1599 formula_from_fo_literal lit, NONE, NONE) |
1593 formula_from_fo_literal lit, NONE, NONE) |