X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FgTopLevel%2Fregtest.ml;h=bee1c28166a54f555ee0448253b4f32b08a6b774;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=2530e34a0ebf1387c99bf10e68f0333f69dfb423;hpb=646303b5ddd2daf3ca5f0e34e830d43057e866bd;p=helm.git diff --git a/helm/gTopLevel/regtest.ml b/helm/gTopLevel/regtest.ml index 2530e34a0..bee1c2816 100644 --- a/helm/gTopLevel/regtest.ml +++ b/helm/gTopLevel/regtest.ml @@ -27,50 +27,66 @@ open Printf let argc = Array.length Sys.argv -let usage () = - prerr_endline "Usage: regtest ..."; - prerr_endline " regtest (-gen|--gen) ..."; - exit 2 - let rawsep = "###" -let sep = Pcre.regexp rawsep -let msg_prefix = "*** REGTEST *** " -let print_msg s = prerr_endline (msg_prefix ^ s) +let sep = Pcre.regexp (sprintf "^%s" rawsep) +let sep2 = Pcre.regexp (sprintf "^%s%s" rawsep rawsep) +let print s = print_string s; flush stdout +let print_endline s = print_endline s +let print_endline_to_channel ch s = output_string ch (s ^ "\n") -type state = Term | EMetasenv | ETerm | EType | EReduced +type state = Term | EEnv | EMetasenv | ETerm | EType | EReduced (* regtest file format * < cic term in concrete syntax > + * separatorseparator INTERPRETATION NUMBER separatorseparator + * separator (* see sep above *) + * < expected disambiguating environment (EnvironmentP3.to_string) > * separator (* see sep above *) - * < expected cic term after disambiguation as PPed by CicPp.ppterm > + * < expected metasenv after disambiguation (CicMetaSubst.ppmetasenv) > * separator (* see sep above *) - * < expected cic type as per type_of as PPed by CicPp.ppterm > + * < expected cic term after disambiguation (CicPp.ppterm) > * separator (* see sep above *) - * < expected reduced cic term as PPed by CicPp.ppterm > + * < expected cic type as per type_of (CicPp.ppterm) > + * separator (* see sep above *) + * < expected reduced cic term as (CicPp.ppterm) > + * ... (* repeat from ... INTERPRETATION NUMBER ... *) *) type regtest = { term: string; (* raw cic term *) + eenv : string; (* disambiguating parsing environment *) emetasenv : string; (* expected metasenv *) eterm: string; (* expected term *) etype: string; (* expected type *) ereduced: string; (* expected reduced term *) } - (* this should be the only function here printing on stdout *) -let print_test test fname = +let print_test tests fname = let oc = open_out fname in - output_string oc - (String.concat "" - [ test.term; rawsep ^ "\n"; - test.emetasenv; rawsep ^ "\n"; - test.eterm; rawsep ^ "\n"; - test.etype; rawsep ^ "\n"; - test.ereduced ]); + output_string oc (List.hd tests).term; + let i = ref 0 in + List.iter + (function test -> + incr i ; + output_string oc + (String.concat "" + [ sprintf "%s%s INTERPRETATION NUMBER %d %s%s\n" rawsep rawsep !i rawsep rawsep ; + sprintf "%s (* disambiguation environment *)\n" rawsep; + test.eenv; + sprintf "%s (* METASENV after disambiguation *)\n" rawsep; + test.emetasenv; + sprintf "%s (* TERM after disambiguation *)\n" rawsep; + test.eterm; + sprintf "%s (* TYPE_OF the disambiguated term *)\n" rawsep; + test.etype; + sprintf "%s (* REDUCED disambiguated term *)\n" rawsep; + test.ereduced ]) + ) tests; close_out oc let parse_regtest = let term = Buffer.create 1024 in (* raw term *) + let eenv = Buffer.create 1024 in (* disambiguating parser environment *) let emetasenv = Buffer.create 1024 in (* expected metasenv *) let eterm = Buffer.create 1024 in (* raw expected term *) let etype = Buffer.create 1024 in (* raw expected type *) @@ -78,118 +94,292 @@ let parse_regtest = let state = ref Term in let bump_state () = match !state with - | Term -> state := EMetasenv + | Term -> state := EEnv + | EEnv -> state := EMetasenv | EMetasenv -> state := ETerm | ETerm -> state := EType | EType -> state := EReduced | EReduced -> assert false in let buffer_of_state = function - | Term -> term | EMetasenv -> emetasenv | ETerm -> eterm | EType -> etype | EReduced -> ereduced + | Term -> term | EEnv -> eenv | EMetasenv -> emetasenv | ETerm -> eterm | EType -> etype + | EReduced -> ereduced + in + let clear_buffers () = + List.iter Buffer.clear [ eenv; emetasenv; eterm; etype; ereduced ] in fun fname -> state := Term; - Buffer.clear term; Buffer.clear emetasenv; Buffer.clear eterm; - Buffer.clear etype; Buffer.clear ereduced; + let first = ref true in + let res = ref [] in + let push_res () = + res := + {term = Buffer.contents term; + eenv = Buffer.contents eenv; + emetasenv = Buffer.contents emetasenv; + eterm = Buffer.contents eterm; + etype = Buffer.contents etype; + ereduced = Buffer.contents ereduced } :: !res ; + in + Buffer.clear term; let ic = open_in fname in (try while true do let line = input_line ic in match line with + | l when Pcre.pmatch ~rex:sep2 l -> + if !first then first := false else push_res () ; + clear_buffers (); + state := Term | l when Pcre.pmatch ~rex:sep l -> bump_state () | l -> Buffer.add_string (buffer_of_state !state) (line ^ "\n") done with End_of_file -> ()); - { term = Buffer.contents term; - emetasenv = Buffer.contents emetasenv; - eterm = Buffer.contents eterm; - etype = Buffer.contents etype; - ereduced = Buffer.contents ereduced } - -let as_expected expected found = (* ignores "term" field *) - let outcome = ref true in - if expected.eterm <> found.eterm then begin - print_msg "Term mismatch"; - print_msg " expected:"; - print_msg (" " ^ expected.eterm); - print_msg " found:"; - print_msg (" " ^ found.eterm); - outcome := false; - end; - if expected.etype <> found.etype then begin - print_msg "Type mismatch"; - print_msg " expected:"; - print_msg (" " ^ expected.etype); - print_msg " found:"; - print_msg (" " ^ found.etype); - outcome := false; - end; - if expected.ereduced <> found.ereduced then begin - print_msg "Reduced term mismatch"; - print_msg " expected:"; - print_msg (" " ^ expected.ereduced); - print_msg " found:"; - print_msg (" " ^ found.ereduced); - outcome := false; - end; - !outcome - -let test_this raw_term = - let empty_context = [] in - let (metasenv, cic_term) = BatchParser.parse raw_term in - let etype = - try - CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv empty_context cic_term) - with - _ -> "MALFORMED" + push_res () ; + List.rev !res + +let as_expected_one och expected found = (* ignores "term" field *) + let eterm_ok = expected.eterm = found.eterm in + let eenv_ok = expected.eenv = found.eenv in + let emetasenv_ok = expected.emetasenv = found.emetasenv in + let etype_ok = expected.etype = found.etype in + let ereduced_ok = expected.ereduced = found.ereduced in + let outcome = + eterm_ok && eenv_ok && emetasenv_ok && etype_ok && ereduced_ok + in + begin + let print_endline s = print_endline_to_channel (Lazy.force och) s in + if not eterm_ok then begin + print_endline "### Term mismatch ###"; + print_endline "# expected:"; + print_endline (" " ^ expected.eterm); + print_endline "# found:"; + print_endline (" " ^ found.eterm); + end; + if not eenv_ok then begin + print_endline "### Disambiguation environment mismatch ###"; + print_endline "# expected:"; + print_endline (" " ^ expected.eenv); + print_endline "# found:"; + print_endline (" " ^ found.eenv); + end; + if not emetasenv_ok then begin + print_endline "### Metasenv mismatch ###"; + print_endline "# expected:"; + print_endline (" " ^ expected.emetasenv); + print_endline "# found:"; + print_endline (" " ^ found.emetasenv); + end; + if not etype_ok then begin + print_endline "### Type mismatch ###"; + print_endline "# expected:"; + print_endline (" " ^ expected.etype); + print_endline "# found:"; + print_endline (" " ^ found.etype); + end; + if expected.ereduced <> found.ereduced then begin + print_endline "### Reduced term mismatch ###"; + print_endline "# expected:"; + print_endline (" " ^ expected.ereduced); + print_endline "# found:"; + print_endline (" " ^ found.ereduced); + end; + end; + outcome + +let as_expected report_fname expected found = + (if Sys.file_exists report_fname then Sys.remove report_fname) ; + let och = lazy (open_out report_fname) in + let print_endline s = print_endline_to_channel (Lazy.force och) s in + let print_interpretation test = + print_endline "## Interpretation dump ##"; + print_endline "# Disambiguation environment:"; + print_endline test.eenv; + print_endline "# Metasenv:"; + print_endline test.emetasenv; + print_endline "# Term:"; + print_endline test.eterm; + print_endline "# Type:"; + print_endline test.etype; + print_endline "# Reduced term:"; + print_endline test.ereduced; in - let ereduced = - try - CicPp.ppterm (CicReduction.whd empty_context cic_term) - with - _ -> "MALFORMED" + let rec aux = + function + [],[] -> true + | ex::extl, fo::fotl -> + let outcome1 = as_expected_one och ex fo in + let outcome2 = aux (extl,fotl) in + outcome1 && outcome2 + | [],found -> + print_endline "### Too many interpretations found:" ; + List.iter print_interpretation found; + false + | expected,[] -> + print_endline "### Too few interpretations found:" ; + List.iter print_interpretation expected; + false in - { - term = raw_term; (* useless *) - emetasenv = CicMetaSubst.ppmetasenv metasenv [] ^ "\n"; - eterm = CicPp.ppterm cic_term ^ "\n"; - etype = etype ^ "\n"; - ereduced = ereduced ^ "\n"; - } - -let main () = - if Sys.argv.(1) = "-gen" || Sys.argv.(1) = "--gen" then begin (* gen mode *) - print_msg "[ Gen mode ]"; - for i = 2 to argc - 1 do - let fname = Sys.argv.(i) in + let outcome = aux (expected,found) in + (if Lazy.lazy_is_val och then close_out (Lazy.force och)) ; + outcome + +let test_this mqi_handle uri_pred raw_term = + let empty_context = [] in + List.map + (function (env, metasenv, cic_term,ugraph ) -> + let etype = + try + let ty, _ = + (CicTypeChecker.type_of_aux' metasenv empty_context cic_term ugraph) + in + CicPp.ppterm ty + with _ -> "MALFORMED" + in + let ereduced = + try + CicPp.ppterm (CicReduction.whd empty_context cic_term) + with _ -> "MALFORMED" + in + { term = raw_term; (* useless *) + eenv = DisambiguatingParser.EnvironmentP3.to_string env ^ "\n"; + emetasenv = CicMetaSubst.ppmetasenv metasenv [] ^ "\n"; + eterm = CicPp.ppterm cic_term ^ "\n"; + etype = etype ^ "\n"; + ereduced = ereduced ^ "\n"; + } + ) (BatchParser.parse mqi_handle ~uri_pred raw_term CicUniv.empty_ugraph) + +let dump_environment filename = + try + let oc = open_out filename in + CicEnvironment.dump_to_channel oc; + close_out oc + with exc -> + prerr_endline + ("DUMP_ENVIRONMENT FAILURE, uncaught excecption " ^ + Printexc.to_string exc) ; + raise exc + +let restore_environment filename = + if Sys.file_exists filename then + begin + try + let ic = open_in filename in + CicEnvironment.restore_from_channel ic; + close_in ic + with exc -> + prerr_endline + ("RESTORE_ENVIRONMENT FAILURE, uncaught excecption " ^ + Printexc.to_string exc) ; + raise exc + end + else + CicEnvironment.empty () + +let main mqi_handle generate dump fnames tryvars prefix varsprefix = + let uri_pred = BatchParser.uri_pred_of_conf tryvars ~prefix ~varsprefix in + if generate then + begin + (* gen mode *) + print_endline "[ Gen mode ]"; + List.iter + (function fname -> let test_fname = fname ^ ".test" in - print_msg (sprintf "Generating regtest %s -> %s\n ..." + let env_fname = fname ^ ".env" in + print_endline (sprintf "Generating regtest %s -> %s\n ..." fname test_fname); - let raw_term = (parse_regtest fname).term in - let result = test_this raw_term in - print_test result test_fname - done - end else begin (* regtest mode *) - prerr_endline "[ Regtest mode ]"; + let raw_term = (List.hd (parse_regtest fname)).term in + let results = test_this mqi_handle uri_pred raw_term in + print_test results test_fname ; + if dump then dump_environment env_fname ; + ) fnames + end else + begin + (* regtest mode *) + print_endline "[ Regtest mode ]"; let (ok, nok) = (ref 0, ref []) in - for i = 1 to argc - 1 do - let fname = Sys.argv.(i) in - prerr_endline ("# " ^ fname); - try - let expected = parse_regtest fname in - let actual = test_this expected.term in - if as_expected expected actual then - incr ok - else - nok := fname :: !nok; - with e -> nok := fname :: !nok - done; - print_msg "Regtest completed:"; - print_msg (sprintf "Succeeded: %d" !ok); - print_msg (sprintf "Failed: %d" (List.length !nok)); - List.iter (fun fname -> print_msg (sprintf " %s failed :-(" fname)) + List.iter + (function fname -> + let env_fname = fname ^ ".env" in + let test_fname = fname ^ ".test" in + let report_fname = fname ^ ".report" in + restore_environment env_fname ; + let time = Unix.gettimeofday () in + print ("Processing " ^ fname ^":\t") ; + let is_ok = + try + let expected = parse_regtest test_fname in + let actual = test_this mqi_handle uri_pred (List.hd expected).term in + if dump then dump_environment env_fname ; + if as_expected report_fname expected actual then + (incr ok ; true) + else + (nok := fname :: !nok ; false) + with e -> (nok := fname :: !nok ; false) + in + let timediff = Unix.gettimeofday () -. time in + print (sprintf "done in %f seconds\t" timediff) ; + print_endline + (if is_ok then + "[ OK ]" + else + "[ FAILED ]") + ) fnames ; + print_endline "*** Summary ***"; + print_endline (sprintf "Succeeded: %d" !ok); + print_endline (sprintf "Failed: %d" (List.length !nok)); + List.iter (fun fname -> print_endline (sprintf " %s failed :-(" fname)) (List.rev !nok) end -let _ = try main () with Invalid_argument _ -> usage () +let _ = + Helm_registry.load_from "gTopLevel.conf.xml"; + HelmLogger.register_log_callback + (fun ?(append_NL = true) msg -> + (if append_NL then prerr_endline else prerr_string) + (HelmLogger.string_of_html_msg msg)); + Helm_registry.load_from "gTopLevel.conf.xml"; + let dbd = + Mysql.quick_connect + ~host:(Helm_registry.get "db.host") + ~user:(Helm_registry.get "db.user") + ~database:(Helm_registry.get "db.database") + () + in + let fnames = ref [] in + let gen = ref false in + let tryvars = ref false in + let dump = ref false in + let nodump = ref false in + let prefix = ref "" in + let varsprefix = ref "###" in + let usage = "regtest [OPTION] ... test1 ..." in + let spec = + ["-gen", Arg.Set gen, + "generate the tests; implies -dump (unless -nodump is specified)" ; + "--gen", Arg.Set gen, + "generate the tests; implies -dump (unless -nodump is specified)" ; + "-dump", Arg.Set dump, "dump the final environment" ; + "--dump", Arg.Set dump, "dump the final environment" ; + "-nodump", Arg.Set nodump, "do not dump the final environment" ; + "--nodump", Arg.Set nodump, "do not dump the final environment" ; + "-vars", Arg.Set tryvars, "try also variables" ; + "-novars", Arg.Clear tryvars, "do not try variables (default)" ; + "-prefix", Arg.Set_string prefix, + "limit object choices to URIs beginning with prefix" ; + "--prefix", Arg.Set_string prefix, + "limit object choices to URIs beginning with prefix" ; + "-varsprefix", Arg.Set_string varsprefix, + "limit variable choices to URIs beginning with prefix; overrides -prefix" ; + "--varsprefix", Arg.Set_string varsprefix, + "limit variable choices to URIs beginning with prefix; overrides -prefix" + ] + in + Arg.parse spec (fun filename -> fnames := filename::!fnames ) usage ; + if !fnames = [] then + Arg.usage spec (Sys.argv.(0) ^ ": missing argument test. You must provide at least one test file.\n" ^ usage) ; + if !varsprefix = "###" then varsprefix := !prefix ; + main dbd !gen ((!gen || !dump) && (not !nodump)) !fnames !tryvars !prefix !varsprefix; + Mysql.disconnect dbd