168 val read_typ: theory -> string -> typ |
168 val read_typ: theory -> string -> typ |
169 val read_typ_syntax: theory -> string -> typ |
169 val read_typ_syntax: theory -> string -> typ |
170 val read_typ_abbrev: theory -> string -> typ |
170 val read_typ_abbrev: theory -> string -> typ |
171 val read_tyname: theory -> string -> typ |
171 val read_tyname: theory -> string -> typ |
172 val read_const: theory -> string -> term |
172 val read_const: theory -> string -> term |
173 val infer_types_simult: Pretty.pp -> theory -> Consts.T -> (indexname -> typ option) -> |
|
174 (indexname -> sort option) -> Name.context -> bool |
|
175 -> (term list * typ) list -> term list * (indexname * typ) list |
|
176 val infer_types: Pretty.pp -> theory -> Consts.T -> (indexname -> typ option) -> |
|
177 (indexname -> sort option) -> Name.context -> bool |
|
178 -> term list * typ -> term * (indexname * typ) list |
|
179 val read_def_terms': Pretty.pp -> (string -> bool) -> Syntax.syntax -> Consts.T -> |
173 val read_def_terms': Pretty.pp -> (string -> bool) -> Syntax.syntax -> Consts.T -> |
180 Proof.context -> (indexname -> typ option) * (indexname -> sort option) -> |
174 (string -> string option) -> Proof.context -> |
|
175 (indexname -> typ option) * (indexname -> sort option) -> |
181 Name.context -> bool -> (string * typ) list -> term list * (indexname * typ) list |
176 Name.context -> bool -> (string * typ) list -> term list * (indexname * typ) list |
182 val read_def_terms: |
177 val read_def_terms: |
183 theory * (indexname -> typ option) * (indexname -> sort option) -> |
178 theory * (indexname -> typ option) * (indexname -> sort option) -> |
184 string list -> bool -> (string * typ) list -> term list * (indexname * typ) list |
179 string list -> bool -> (string * typ) list -> term list * (indexname * typ) list |
185 val simple_read_term: theory -> typ -> string -> term |
180 val simple_read_term: theory -> typ -> string -> term |
510 |
504 |
511 fun read_sort' syn ctxt str = |
505 fun read_sort' syn ctxt str = |
512 let |
506 let |
513 val thy = ProofContext.theory_of ctxt; |
507 val thy = ProofContext.theory_of ctxt; |
514 val _ = Context.check_thy thy; |
508 val _ = Context.check_thy thy; |
515 val S = intern_sort thy (Syntax.read_sort ctxt syn str); |
509 val S = Syntax.read_sort ctxt syn (intern_sort thy) str; |
516 in certify_sort thy S handle TYPE (msg, _, _) => error msg end; |
510 in certify_sort thy S handle TYPE (msg, _, _) => error msg end; |
517 |
511 |
518 fun read_sort thy str = read_sort' (syn_of thy) (ProofContext.init thy) str; |
512 fun read_sort thy str = read_sort' (syn_of thy) (ProofContext.init thy) str; |
519 |
513 |
520 |
514 |
528 val cert_arity = prep_arity (K I) certify_sort; |
522 val cert_arity = prep_arity (K I) certify_sort; |
529 |
523 |
530 |
524 |
531 (* types *) |
525 (* types *) |
532 |
526 |
|
527 fun get_sort tsig def_sort raw_env = |
|
528 let |
|
529 fun eq ((xi, S), (xi', S')) = |
|
530 Term.eq_ix (xi, xi') andalso Type.eq_sort tsig (S, S'); |
|
531 val env = distinct eq raw_env; |
|
532 val _ = (case duplicates (eq_fst (op =)) env of [] => () |
|
533 | dups => error ("Inconsistent sort constraints for type variable(s) " |
|
534 ^ commas_quote (map (Term.string_of_vname' o fst) dups))); |
|
535 |
|
536 fun get xi = |
|
537 (case (AList.lookup (op =) env xi, def_sort xi) of |
|
538 (NONE, NONE) => Type.defaultS tsig |
|
539 | (NONE, SOME S) => S |
|
540 | (SOME S, NONE) => S |
|
541 | (SOME S, SOME S') => |
|
542 if Type.eq_sort tsig (S, S') then S' |
|
543 else error ("Sort constraint inconsistent with default for type variable " ^ |
|
544 quote (Term.string_of_vname' xi))); |
|
545 in get end; |
|
546 |
533 local |
547 local |
534 |
548 |
535 fun gen_read_typ' cert syn ctxt def_sort str = |
549 fun gen_read_typ' cert syn ctxt def_sort str = |
536 let |
550 let |
537 val thy = ProofContext.theory_of ctxt; |
551 val thy = ProofContext.theory_of ctxt; |
538 val _ = Context.check_thy thy; |
552 val _ = Context.check_thy thy; |
539 val get_sort = TypeInfer.get_sort (tsig_of thy) def_sort (intern_sort thy); |
553 val T = intern_tycons thy |
540 val T = intern_tycons thy (Syntax.read_typ ctxt syn get_sort (intern_sort thy) str); |
554 (Syntax.read_typ ctxt syn (get_sort (tsig_of thy) def_sort) (intern_sort thy) str); |
541 in cert thy T handle TYPE (msg, _, _) => error msg end |
555 in cert thy T handle TYPE (msg, _, _) => error msg end |
542 handle ERROR msg => cat_error msg ("The error(s) above occurred in type " ^ quote str); |
556 handle ERROR msg => cat_error msg ("The error(s) above occurred in type " ^ quote str); |
543 |
557 |
544 fun gen_read_typ cert (thy, def_sort) str = |
558 fun gen_read_typ cert (thy, def_sort) str = |
545 gen_read_typ' cert (syn_of thy) (ProofContext.init thy) def_sort str; |
559 gen_read_typ' cert (syn_of thy) (ProofContext.init thy) def_sort str; |
568 |
582 |
569 val read_const = Consts.read_const o consts_of; |
583 val read_const = Consts.read_const o consts_of; |
570 |
584 |
571 |
585 |
572 |
586 |
573 (** infer_types **) (*exception ERROR*) |
587 (* read_def_terms -- read terms and infer types *) (*exception ERROR*) |
574 |
588 |
575 (* |
589 (* |
576 def_type: partial map from indexnames to types (constrains Frees and Vars) |
590 def_type: partial map from indexnames to types (constrains Frees and Vars) |
577 def_sort: partial map from indexnames to sorts (constrains TFrees and TVars) |
591 def_sort: partial map from indexnames to sorts (constrains TFrees and TVars) |
578 used: context of already used type variables |
592 used: context of already used type variables |
579 freeze: if true then generated parameters are turned into TFrees, else TVars |
593 freeze: if true then generated parameters are turned into TFrees, else TVars |
580 |
|
581 termss: lists of alternative parses (only one combination should be type-correct) |
|
582 typs: expected types |
|
583 *) |
594 *) |
584 |
595 |
585 fun infer_types_simult pp thy consts def_type def_sort used freeze args = |
596 fun read_def_terms' pp is_logtype syn consts fixed ctxt (def_type, def_sort) used freeze sTs = |
586 let |
597 let |
|
598 val thy = ProofContext.theory_of ctxt; |
|
599 val tsig = tsig_of thy; |
|
600 |
|
601 (*read terms -- potentially ambiguous*) |
|
602 val map_const = try (#1 o Term.dest_Const o Consts.read_const consts); |
|
603 fun map_free x = |
|
604 (case fixed x of |
|
605 NONE => if is_some (def_type (x, ~1)) then SOME x else NONE |
|
606 | some => some); |
|
607 val read = |
|
608 Syntax.read_term (get_sort tsig def_sort) map_const map_free |
|
609 (intern_tycons thy) (intern_sort thy) ctxt is_logtype syn; |
|
610 |
|
611 val args = sTs |> map (fn (s, raw_T) => |
|
612 let val T = certify_typ thy raw_T handle TYPE (msg, _, _) => error msg |
|
613 in (read T s, T) end); |
|
614 |
|
615 (*brute-force disambiguation via type-inference*) |
587 val termss = fold_rev (multiply o fst) args [[]]; |
616 val termss = fold_rev (multiply o fst) args [[]]; |
588 val typs = |
617 val typs = map snd args; |
589 map (fn (_, T) => certify_typ thy T handle TYPE (msg, _, _) => error msg) args; |
618 |
590 |
619 fun infer ts = Result (TypeInfer.infer_types (Syntax.pp_show_brackets pp) tsig |
591 fun infer ts = Result (TypeInfer.infer_types (Syntax.pp_show_brackets pp) (tsig_of thy) |
620 (try (Consts.the_constraint consts)) def_type used freeze (ts ~~ typs) |>> map fst) |
592 (try (Consts.the_constraint consts)) def_type def_sort (Consts.intern consts) |
|
593 (intern_tycons thy) (intern_sort thy) used freeze typs ts) |
|
594 handle TYPE (msg, _, _) => Exn (ERROR msg); |
621 handle TYPE (msg, _, _) => Exn (ERROR msg); |
595 |
622 |
596 val err_results = map infer termss; |
623 val err_results = map infer termss; |
597 val errs = map_filter (fn Exn (ERROR msg) => SOME msg | _ => NONE) err_results; |
624 val errs = map_filter (fn Exn (ERROR msg) => SOME msg | _ => NONE) err_results; |
598 val results = map_filter get_result err_results; |
625 val results = map_filter get_result err_results; |
602 if ambiguity > 1 andalso ambiguity <= ! Syntax.ambiguity_level then |
629 if ambiguity > 1 andalso ambiguity <= ! Syntax.ambiguity_level then |
603 "Got more than one parse tree.\n\ |
630 "Got more than one parse tree.\n\ |
604 \Retry with smaller Syntax.ambiguity_level for more information." |
631 \Retry with smaller Syntax.ambiguity_level for more information." |
605 else ""; |
632 else ""; |
606 in |
633 in |
607 if null results then (cat_error (ambig_msg ()) (cat_lines errs)) |
634 if null results then cat_error (ambig_msg ()) (cat_lines errs) |
608 else if length results = 1 then |
635 else if length results = 1 then |
609 (if ambiguity > ! Syntax.ambiguity_level then |
636 (if ambiguity > ! Syntax.ambiguity_level then |
610 warning "Fortunately, only one parse tree is type correct.\n\ |
637 warning "Fortunately, only one parse tree is type correct.\n\ |
611 \You may still want to disambiguate your grammar or your input." |
638 \You may still want to disambiguate your grammar or your input." |
612 else (); hd results) |
639 else (); hd results) |
613 else (cat_error (ambig_msg ()) ("More than one term is type correct:\n" ^ |
640 else cat_error (ambig_msg ()) ("More than one term is type correct:\n" ^ |
614 cat_lines (map (Pretty.string_of_term pp) (maps fst results)))) |
641 cat_lines (map (Pretty.string_of_term pp) (maps fst results))) |
615 end; |
642 end; |
616 |
|
617 fun infer_types pp thy consts def_type def_sort used freeze tsT = |
|
618 apfst hd (infer_types_simult pp thy consts def_type def_sort used freeze [tsT]); |
|
619 |
|
620 |
|
621 (* read_def_terms -- read terms and infer types *) (*exception ERROR*) |
|
622 |
|
623 fun read_def_terms' pp is_logtype syn consts ctxt (types, sorts) used freeze sTs = |
|
624 let |
|
625 val thy = ProofContext.theory_of ctxt; |
|
626 fun read (s, T) = |
|
627 let val T' = certify_typ thy T handle TYPE (msg, _, _) => error msg |
|
628 in (Syntax.read ctxt is_logtype syn T' s, T') end; |
|
629 in infer_types_simult pp thy consts types sorts used freeze (map read sTs) end; |
|
630 |
643 |
631 fun read_def_terms (thy, types, sorts) used freeze sTs = |
644 fun read_def_terms (thy, types, sorts) used freeze sTs = |
632 let |
645 let |
633 val pp = pp thy; |
646 val pp = pp thy; |
634 val consts = consts_of thy; |
647 val consts = consts_of thy; |
635 val cert_consts = Consts.certify pp (tsig_of thy) consts; |
648 val cert_consts = Consts.certify pp (tsig_of thy) consts; |
636 val (ts, inst) = |
649 val (ts, inst) = |
637 read_def_terms' pp (is_logtype thy) (syn_of thy) consts |
650 read_def_terms' pp (is_logtype thy) (syn_of thy) consts (K NONE) |
638 (ProofContext.init thy) (types, sorts) (Name.make_context used) freeze sTs; |
651 (ProofContext.init thy) (types, sorts) (Name.make_context used) freeze sTs; |
639 in (map cert_consts ts, inst) end; |
652 in (map cert_consts ts, inst) end; |
640 |
653 |
641 fun simple_read_term thy T s = |
654 fun simple_read_term thy T s = |
642 let val ([t], _) = read_def_terms (thy, K NONE, K NONE) [] true [(s, T)] |
655 let val ([t], _) = read_def_terms (thy, K NONE, K NONE) [] true [(s, T)] |