566 fun read_def_terms' |
566 fun read_def_terms' |
567 pp is_logtype syn consts map_free ctxt (def_type, def_sort) used freeze raw_args = |
567 pp is_logtype syn consts map_free ctxt (def_type, def_sort) used freeze raw_args = |
568 let |
568 let |
569 val thy = ProofContext.theory_of ctxt; |
569 val thy = ProofContext.theory_of ctxt; |
570 |
570 |
571 fun infer args = TypeInfer.infer_types (Syntax.pp_show_brackets pp) (tsig_of thy) |
571 fun infer args = TypeInfer.infer_types pp (tsig_of thy) |
572 Type.mode_default (try (Consts.the_constraint consts)) def_type used freeze args |>> map fst |
572 Type.mode_default (try (Consts.the_constraint consts)) def_type used freeze args |>> map fst |
573 handle TYPE (msg, _, _) => error msg; |
573 handle TYPE (msg, _, _) => error msg; |
574 |
574 |
575 (*brute-force disambiguation via type-inference*) |
575 fun check T t = Exn.Result (singleton (fst o infer) (t, T)) |
576 fun disambig _ [t] = t |
576 handle ERROR msg => Exn.Exn (ERROR msg); |
577 | disambig T ts = |
|
578 let |
|
579 fun try_infer t = Exn.Result (singleton (fst o infer) (t, T)) |
|
580 handle ERROR msg => Exn.Exn (ERROR msg); |
|
581 val err_results = map try_infer ts; |
|
582 val errs = map_filter (fn Exn.Exn (ERROR msg) => SOME msg | _ => NONE) err_results; |
|
583 val results = map_filter Exn.get_result err_results; |
|
584 |
|
585 val ambiguity = length ts; |
|
586 fun ambig_msg () = |
|
587 if ambiguity > 1 andalso ambiguity <= ! Syntax.ambiguity_level then |
|
588 "Got more than one parse tree.\n\ |
|
589 \Retry with smaller Syntax.ambiguity_level for more information." |
|
590 else ""; |
|
591 in |
|
592 if null results then cat_error (ambig_msg ()) (cat_lines errs) |
|
593 else if length results = 1 then |
|
594 (if ambiguity > ! Syntax.ambiguity_level then |
|
595 warning "Fortunately, only one parse tree is type correct.\n\ |
|
596 \You may still want to disambiguate your grammar or your input." |
|
597 else (); hd results) |
|
598 else cat_error (ambig_msg ()) ("More than one term is type correct:\n" ^ |
|
599 cat_lines (map (Pretty.string_of_term pp) ts)) |
|
600 end; |
|
601 |
|
602 (*read term*) |
|
603 val map_const = try (#1 o Term.dest_Const o Consts.read_const consts); |
577 val map_const = try (#1 o Term.dest_Const o Consts.read_const consts); |
604 fun read T = disambig T o Syntax.standard_parse_term (get_sort thy def_sort) map_const map_free |
578 fun read T = Syntax.standard_parse_term pp (check T) (get_sort thy def_sort) map_const map_free |
605 (intern_tycons thy) (intern_sort thy) ctxt is_logtype syn T; |
579 (intern_tycons thy) (intern_sort thy) ctxt is_logtype syn T; |
606 in |
580 in |
607 raw_args |
581 raw_args |
608 |> map (fn (s, raw_T) => |
582 |> map (fn (s, raw_T) => |
609 let val T = certify_typ thy raw_T handle TYPE (msg, _, _) => error msg |
583 let val T = certify_typ thy raw_T handle TYPE (msg, _, _) => error msg |