X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FgTopLevel%2Fregtest.ml;h=bee1c28166a54f555ee0448253b4f32b08a6b774;hb=97c2d258a5c524eb5c4b85208899d80751a2c82f;hp=fb91bf2004f55f77adc6b1c8f68c4c4b265d3d9b;hpb=cb5df9e3b544239848e779f3eaa542174b5c5806;p=helm.git diff --git a/helm/gTopLevel/regtest.ml b/helm/gTopLevel/regtest.ml index fb91bf200..bee1c2816 100644 --- a/helm/gTopLevel/regtest.ml +++ b/helm/gTopLevel/regtest.ml @@ -34,10 +34,13 @@ 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 metasenv after disambiguation (CicMetaSubst.ppmetasenv) > * separator (* see sep above *) @@ -46,10 +49,12 @@ type state = Term | EMetasenv | ETerm | EType | EReduced * < 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 *) @@ -66,6 +71,8 @@ let print_test tests fname = 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; @@ -79,6 +86,7 @@ let print_test tests fname = 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 *) @@ -86,18 +94,19 @@ 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 + | Term -> term | EEnv -> eenv | EMetasenv -> emetasenv | ETerm -> eterm | EType -> etype | EReduced -> ereduced in let clear_buffers () = - List.iter Buffer.clear [ emetasenv; eterm; etype; ereduced ] + List.iter Buffer.clear [ eenv; emetasenv; eterm; etype; ereduced ] in fun fname -> state := Term; @@ -105,7 +114,8 @@ let parse_regtest = let res = ref [] in let push_res () = res := - { term = Buffer.contents term; + {term = Buffer.contents term; + eenv = Buffer.contents eenv; emetasenv = Buffer.contents emetasenv; eterm = Buffer.contents eterm; etype = Buffer.contents etype; @@ -130,10 +140,13 @@ let parse_regtest = 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 && emetasenv_ok && etype_ok && ereduced_ok 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 @@ -143,6 +156,13 @@ let as_expected_one och expected found = (* ignores "term" field *) 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:"; @@ -171,17 +191,33 @@ 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 rec aux = function [],[] -> true | ex::extl, fo::fotl -> - as_expected_one och ex fo && - aux (extl,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" ; + print_endline "### Too many interpretations found:" ; + List.iter print_interpretation found; false | expected,[] -> - print_endline "### Too few interpretations found" ; + print_endline "### Too few interpretations found:" ; + List.iter print_interpretation expected; false in let outcome = aux (expected,found) in @@ -191,11 +227,13 @@ let as_expected report_fname expected found = let test_this mqi_handle uri_pred raw_term = let empty_context = [] in List.map - (function (metasenv, cic_term) -> + (function (env, metasenv, cic_term,ugraph ) -> let etype = try - CicPp.ppterm - (CicTypeChecker.type_of_aux' metasenv empty_context cic_term) + let ty, _ = + (CicTypeChecker.type_of_aux' metasenv empty_context cic_term ugraph) + in + CicPp.ppterm ty with _ -> "MALFORMED" in let ereduced = @@ -203,14 +241,14 @@ let test_this mqi_handle uri_pred raw_term = CicPp.ppterm (CicReduction.whd empty_context cic_term) with _ -> "MALFORMED" in - { - term = raw_term; (* useless *) + { 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) + ) (BatchParser.parse mqi_handle ~uri_pred raw_term CicUniv.empty_ugraph) let dump_environment filename = try @@ -239,8 +277,8 @@ let restore_environment filename = else CicEnvironment.empty () -let main mqi_handle generate dump fnames tryvars varsprefix = - let uri_pred = BatchParser.uri_pred_of_conf tryvars varsprefix in +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 *) @@ -302,16 +340,21 @@ let _ = (fun ?(append_NL = true) msg -> (if append_NL then prerr_endline else prerr_string) (HelmLogger.string_of_html_msg msg)); - - let mqi_debug_fun = ignore in - let mqi_handle = MQIConn.init ~log:mqi_debug_fun () in - + 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 varsprefix = ref "" in + let prefix = ref "" in + let varsprefix = ref "###" in let usage = "regtest [OPTION] ... test1 ..." in let spec = ["-gen", Arg.Set gen, @@ -324,14 +367,19 @@ let _ = "--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" ; + "limit variable choices to URIs beginning with prefix; overrides -prefix" ; "--varsprefix", Arg.Set_string varsprefix, - "limit variable choices to URIs beginning with prefix" ; + "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) ; - main mqi_handle !gen ((!gen || !dump) && (not !nodump)) !fnames !tryvars !varsprefix; - MQIConn.close mqi_handle + if !varsprefix = "###" then varsprefix := !prefix ; + main dbd !gen ((!gen || !dump) && (not !nodump)) !fnames !tryvars !prefix !varsprefix; + Mysql.disconnect dbd