src/Pure/sign.ML
changeset 24370 757b093e3459
parent 24273 1d4b411caf44
child 24485 687bbb686ef9
equal deleted inserted replaced
24369:0cb1f4d76452 24370:757b093e3459
   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