src/Tools/isac/Specify/m-match.sml
changeset 60650 06ec8abfd3bc
parent 60590 35846e25713e
child 60653 fff1c0f0a9e7
     1.1 --- a/src/Tools/isac/Specify/m-match.sml	Wed Jan 11 09:23:18 2023 +0100
     1.2 +++ b/src/Tools/isac/Specify/m-match.sml	Wed Jan 11 11:38:01 2023 +0100
     1.3 @@ -153,6 +153,8 @@
     1.4     an type-error is reported immediately, raises an exn, 
     1.5     subsequent handling of exn provides 2nd part of error message *)
     1.6  fun mtc thy (str, (dsc, _)) (ty $ var) =
     1.7 +    let val ctxt = Proof_Context.init_global thy
     1.8 +    in
     1.9      ((Thm.global_cterm_of thy (dsc $ var);(*type check*)
    1.10        SOME (([1], str, dsc, (*[var]*)
    1.11  	    Input_Descript.split' (dsc, var))) (*:ori without leading #*))
    1.12 @@ -160,16 +162,19 @@
    1.13  	      (tracing (dashs 70 ^ "\n"
    1.14  	        ^ "*** ERROR while creating the items for the model of the ->problem\n"
    1.15  	        ^ "*** from the ->stac with ->typeconstructor in arglist:\n"
    1.16 -	        ^ "*** item (->description ->value): " ^ UnparseC.term dsc ^ " " ^ UnparseC.term var ^ "\n"
    1.17 -	        ^ "*** description: " ^ TermC.term_detail2str dsc
    1.18 -	        ^ "*** value: " ^ TermC.term_detail2str var
    1.19 -	        ^ "*** typeconstructor in script: " ^ TermC.term_detail2str ty
    1.20 +	        ^ "*** item (->description ->value): " ^ UnparseC.term_in_ctxt ctxt dsc ^ " " ^ UnparseC.term_in_ctxt ctxt var ^ "\n"
    1.21 +	        ^ "*** description: " ^ TermC.string_of_detail ctxt dsc
    1.22 +	        ^ "*** value: " ^ TermC.string_of_detail ctxt var
    1.23 +	        ^ "*** typeconstructor in script: " ^ TermC.string_of_detail ctxt ty
    1.24  	        ^ "*** checked by theory: " ^ Context.theory_name thy ^ "\n"
    1.25  	        ^ "*** " ^ dots 66);
    1.26            writeln (@{make_string} e);
    1.27            Exn.reraise e; (*raise ERROR "actual args do not match formal args";FIXXXME.WN100916*)
    1.28        NONE))
    1.29 -  | mtc _ _ t = raise ERROR ("mtc: uncovered case with" ^ UnparseC.term t)
    1.30 +    end
    1.31 +  | mtc thy _ t =
    1.32 +    let val ctxt = Proof_Context.init_global thy
    1.33 +    in raise ERROR ("mtc: uncovered case with" ^ UnparseC.term_in_ctxt ctxt t) end
    1.34  
    1.35  (* match each pat of the model-pattern with an actual argument;
    1.36     precondition: copy-named vars are filtered out            *)