X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=helm%2Focaml%2Fcic_disambiguation%2Fdisambiguate.ml;h=ce26f935131f418f26963c4e8121ba7948a74e15;hb=a56837c8e421a9d1e71566bde12ea8cc1518cfba;hp=85bdc689cc14e6b2d234755f5bad7f5a90c3fe78;hpb=2141f67b35b9ea866217ab2b5af1d5f24704454c;p=helm.git diff --git a/helm/ocaml/cic_disambiguation/disambiguate.ml b/helm/ocaml/cic_disambiguation/disambiguate.ml index 85bdc689c..ce26f9351 100644 --- a/helm/ocaml/cic_disambiguation/disambiguate.ml +++ b/helm/ocaml/cic_disambiguation/disambiguate.ml @@ -28,17 +28,17 @@ open Printf open DisambiguateTypes open UriManager -exception No_choices of domain_item -exception NoWellTypedInterpretation +exception NoWellTypedInterpretation of + (Token.flocation option * string Lazy.t) list exception PathNotWellFormed (** raised when an environment is not enough informative to decide *) -exception Try_again +exception Try_again of string Lazy.t type aliases = bool * DisambiguateTypes.environment let debug = false -let debug_print = if debug then prerr_endline else ignore +let debug_print s = if debug then prerr_endline (Lazy.force s) else () (* (** print benchmark information *) @@ -49,16 +49,6 @@ let domain_size = ref 0 let choices_avg = ref 0. *) -let floc_of_loc (loc_begin, loc_end) = - let floc_begin = - { Lexing.pos_fname = ""; Lexing.pos_lnum = -1; Lexing.pos_bol = -1; - Lexing.pos_cnum = loc_begin } - in - let floc_end = { floc_begin with Lexing.pos_cnum = loc_end } in - (floc_begin, floc_end) - -let dummy_floc = floc_of_loc (-1, -1) - let descr_of_domain_item = function | Id s -> s | Symbol (s, _) -> s @@ -66,43 +56,56 @@ let descr_of_domain_item = function type 'a test_result = | Ok of 'a * Cic.metasenv - | Ko - | Uncertain + | Ko of Token.flocation option * string Lazy.t + | Uncertain of Token.flocation option * string Lazy.t -let refine_term metasenv context uri term ugraph = +let refine_term metasenv context uri term ugraph ~localization_tbl = (* if benchmark then incr actual_refinements; *) assert (uri=None); - let metasenv, term = - CicMkImplicit.expand_implicits metasenv [] context term in - debug_print (sprintf "TEST_INTERPRETATION: %s" (CicPp.ppterm term)); + debug_print (lazy (sprintf "TEST_INTERPRETATION: %s" (CicPp.ppterm term))); try let term', _, metasenv',ugraph1 = - CicRefine.type_of_aux' metasenv context term ugraph in + CicRefine.type_of_aux' metasenv context term ugraph ~localization_tbl in (Ok (term', metasenv')),ugraph1 with - | CicRefine.Uncertain s -> - debug_print ("UNCERTAIN!!! [" ^ s ^ "] " ^ CicPp.ppterm term) ; - Uncertain,ugraph - | CicRefine.RefineFailure msg -> - debug_print (sprintf "PRUNED!!!\nterm%s\nmessage:%s" - (CicPp.ppterm term) msg); - Ko,ugraph + exn -> + let rec process_exn loc = + function + HExtlib.Localized (loc,exn) -> process_exn (Some loc) exn + | CicRefine.Uncertain msg -> + debug_print (lazy ("UNCERTAIN!!! [" ^ (Lazy.force msg) ^ "] " ^ CicPp.ppterm term)) ; + Uncertain (loc,msg),ugraph + | CicRefine.RefineFailure msg -> + debug_print (lazy (sprintf "PRUNED!!!\nterm%s\nmessage:%s" + (CicPp.ppterm term) (Lazy.force msg))); + Ko (loc,msg),ugraph + | exn -> raise exn + in + process_exn None exn -let refine_obj metasenv context uri obj ugraph = +let refine_obj metasenv context uri obj ugraph ~localization_tbl = assert (context = []); - let metasenv, obj = CicMkImplicit.expand_implicits_in_obj metasenv [] obj in - debug_print (sprintf "TEST_INTERPRETATION: %s" (CicPp.ppobj obj)); + debug_print (lazy (sprintf "TEST_INTERPRETATION: %s" (CicPp.ppobj obj))) ; try - let obj', metasenv,ugraph = CicRefine.typecheck metasenv uri obj in + let obj', metasenv,ugraph = + CicRefine.typecheck metasenv uri obj ~localization_tbl + in (Ok (obj', metasenv)),ugraph with - | CicRefine.Uncertain s -> - debug_print ("UNCERTAIN!!! [" ^ s ^ "] " ^ CicPp.ppobj obj) ; - Uncertain,ugraph - | CicRefine.RefineFailure msg -> - debug_print (sprintf "PRUNED!!!\nterm%s\nmessage:%s" - (CicPp.ppobj obj) msg); - Ko,ugraph + exn -> + let rec process_exn loc = + function + HExtlib.Localized (loc,exn) -> process_exn (Some loc) exn + | CicRefine.Uncertain msg -> + debug_print (lazy ("UNCERTAIN!!! [" ^ (Lazy.force msg) ^ "] " ^ CicPp.ppobj obj)) ; + Uncertain (loc,msg),ugraph + | CicRefine.RefineFailure msg -> + debug_print (lazy (sprintf "PRUNED!!!\nterm%s\nmessage:%s" + (CicPp.ppobj obj) (Lazy.force msg))) ; + Ko (loc,msg),ugraph + | exn -> raise exn + in + process_exn None exn let resolve (env: codomain_item Environment.t) (item: domain_item) ?(num = "") ?(args = []) () = try @@ -112,7 +115,7 @@ let resolve (env: codomain_item Environment.t) (item: domain_item) ?(num = "") ? (DisambiguateTypes.string_of_domain_item item)) (* TODO move it to Cic *) -let find_in_environment name (context: Cic.name list) = +let find_in_context name (context: Cic.name list) = let rec aux acc = function | [] -> raise Not_found | Cic.Name hd :: tl when hd = name -> acc @@ -120,11 +123,15 @@ let find_in_environment name (context: Cic.name list) = in aux 1 context -let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast = +let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast + ~localization_tbl += assert (uri = None); let rec aux loc (context: Cic.name list) = function | CicNotationPt.AttributedTerm (`Loc loc, term) -> - aux loc context term + let res = aux loc context term in + Cic.CicHash.add localization_tbl res loc; + res | CicNotationPt.AttributedTerm (_, term) -> aux loc context term | CicNotationPt.Appl (CicNotationPt.Symbol (symb, i) :: args) -> let cic_args = List.map (aux loc context) args in @@ -144,7 +151,7 @@ let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast = | CicNotationPt.Case (term, indty_ident, outtype, branches) -> let cic_term = aux loc context term in let cic_outtype = aux_option loc context None outtype in - let do_branch ((head, args), term) = + let do_branch ((head, _, args), term) = let rec do_branch' context = function | [] -> aux loc context term | (name, typ) :: tl -> @@ -161,22 +168,28 @@ let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast = in let (indtype_uri, indtype_no) = match indty_ident with - | Some indty_ident -> - (match resolve env (Id indty_ident) () with + | Some (indty_ident, _) -> + (match resolve env (Id indty_ident) () with | Cic.MutInd (uri, tyno, _) -> (uri, tyno) - | Cic.Implicit _ -> raise Try_again - | _ -> raise Invalid_choice) + | Cic.Implicit _ -> + raise (Try_again (lazy "The type of the term to be matched + is still unknown")) + | _ -> + raise (Invalid_choice (lazy "The type of the term to be matched is not (co)inductive!"))) | None -> let fst_constructor = match branches with - | ((head, _), _) :: _ -> head - | [] -> raise Invalid_choice + | ((head, _, _), _) :: _ -> head + | [] -> raise (Invalid_choice (lazy "The type of the term to be matched is an inductive type without constructors that cannot be determined")) in (match resolve env (Id fst_constructor) () with | Cic.MutConstruct (indtype_uri, indtype_no, _, _) -> (indtype_uri, indtype_no) - | Cic.Implicit _ -> raise Try_again - | _ -> raise Invalid_choice) + | Cic.Implicit _ -> + raise (Try_again (lazy "The type of the term to be matched + is still unknown")) + | _ -> + raise (Invalid_choice (lazy "The type of the term to be matched is not (co)inductive!"))) in Cic.MutCase (indtype_uri, indtype_no, cic_outtype, cic_term, (List.map do_branch branches)) @@ -226,14 +239,37 @@ let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast = | `Inductive -> (fun (var, _, _, _) cic -> incr counter; - Cic.LetIn (Cic.Name var, Cic.Fix (!counter, funs), cic)) + let fix = Cic.Fix (!counter,funs) in + match cic with + Cic.Rel 1 -> fix + | (Cic.Appl (Cic.Rel 1::l)) -> + (try + let l' = + List.map + (function t -> + let t',subst,metasenv = + CicMetaSubst.delift_rels [] [] 1 t + in + assert (subst=[]); + assert (metasenv=[]); + t') l + in + Cic.Appl (fix::l') + with + CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> + Cic.LetIn (Cic.Name var, fix, cic)) + | _ -> Cic.LetIn (Cic.Name var, fix, cic)) | `CoInductive -> let funs = List.map (fun (name, _, typ, body) -> (name, typ, body)) funs in (fun (var, _, _, _) cic -> incr counter; - Cic.LetIn (Cic.Name var, Cic.CoFix (!counter, funs), cic)) + let cofix = Cic.CoFix (!counter,funs) in + match cic with + Cic.Rel 1 -> cofix + | (Cic.Appl (Cic.Rel 1::l)) -> Cic.Appl (cofix::l) + | _ -> Cic.LetIn (Cic.Name var, cofix, cic)) in List.fold_right (build_term inductiveFuns) inductiveFuns cic_body | CicNotationPt.Ident _ @@ -243,7 +279,7 @@ let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast = let is_uri = function CicNotationPt.Uri _ -> true | _ -> false in (try if is_uri ast then raise Not_found;(* don't search the env for URIs *) - let index = find_in_environment name context in + let index = find_in_context name context in if subst <> None then CicNotationPt.fail loc "Explicit substitutions not allowed here"; Cic.Rel index @@ -268,7 +304,7 @@ let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast = (try List.assoc s ids_to_uris, aux loc context term with Not_found -> - raise Invalid_choice)) + raise (Invalid_choice (lazy "The provided explicit named substitution is trying to instantiate a named variable the object is not abstracted on")))) subst | None -> List.map (fun uri -> uri, Cic.Implicit None) uris) in @@ -302,20 +338,20 @@ let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast = Cic.MutConstruct (uri, i, j, mk_subst uris) | Cic.Meta _ | Cic.Implicit _ as t -> (* - debug_print (sprintf + debug_print (lazy (sprintf "Warning: %s must be instantiated with _[%s] but we do not enforce it" (CicPp.ppterm t) (String.concat "; " (List.map (fun (s, term) -> s ^ " := " ^ CicNotationPtPp.pp_term term) - subst))); + subst)))); *) t | _ -> - raise Invalid_choice + raise (Invalid_choice (lazy "??? Can this happen?")) with CicEnvironment.CircularDependency _ -> - raise Invalid_choice)) + raise (Invalid_choice (lazy "Circular dependency in the environment")))) | CicNotationPt.Implicit -> Cic.Implicit None | CicNotationPt.UserInput -> Cic.Implicit (Some `Hole) | CicNotationPt.Num (num, i) -> resolve env (Num i) ~num () @@ -328,7 +364,7 @@ let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast = Cic.Meta (index, cic_subst) | CicNotationPt.Sort `Prop -> Cic.Sort Cic.Prop | CicNotationPt.Sort `Set -> Cic.Sort Cic.Set - | CicNotationPt.Sort `Type -> Cic.Sort (Cic.Type (CicUniv.fresh())) (* TASSI *) + | CicNotationPt.Sort (`Type u) -> Cic.Sort (Cic.Type u) | CicNotationPt.Sort `CProp -> Cic.Sort Cic.CProp | CicNotationPt.Symbol (symbol, instance) -> resolve env (Symbol (symbol, instance)) () @@ -337,18 +373,21 @@ let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast = | None -> Cic.Implicit annotation | Some term -> aux loc context term in - match ast with - | CicNotationPt.AttributedTerm (`Loc loc, term) -> aux loc context term - | term -> aux dummy_floc context term + aux dummy_floc context ast let interpretate_path ~context path = - interpretate_term ~context ~env:Environment.empty ~uri:None ~is_path:true path + let localization_tbl = Cic.CicHash.create 23 in + (* here we are throwing away useful localization informations!!! *) + fst ( + interpretate_term ~context ~env:Environment.empty ~uri:None ~is_path:true + path ~localization_tbl, localization_tbl) -let interpretate_obj ~context ~env ~uri ~is_path obj = +let interpretate_obj ~context ~env ~uri ~is_path obj ~localization_tbl = assert (context = []); assert (is_path = false); + let interpretate_term = interpretate_term ~localization_tbl in match obj with - | GrafiteAst.Inductive (params,tyl) -> + | CicNotationPt.Inductive (params,tyl) -> let uri = match uri with Some uri -> uri | None -> assert false in let context,params = let context,res = @@ -369,7 +408,7 @@ let interpretate_obj ~context ~env ~uri ~is_path obj = (fun (i,res) (name,_,_,_) -> i + 1,(name,name,Cic.MutInd (uri,i,[]))::res ) (0,[]) tyl) in - let con_env = DisambiguateTypes.singleton_env_of_list name_to_uris env in + let con_env = DisambiguateTypes.env_of_list name_to_uris env in let undebrujin t = snd (List.fold_right @@ -396,7 +435,7 @@ let interpretate_obj ~context ~env ~uri ~is_path obj = ) tyl in Cic.InductiveDefinition (tyl,[],List.length params,[]) - | GrafiteAst.Record (params,name,ty,fields) -> + | CicNotationPt.Record (params,name,ty,fields) -> let uri = match uri with Some uri -> uri | None -> assert false in let context,params = let context,res = @@ -434,7 +473,7 @@ let interpretate_obj ~context ~env ~uri ~is_path obj = let field_names = List.map fst fields in Cic.InductiveDefinition (tyl,[],List.length params,[`Class (`Record field_names)]) - | GrafiteAst.Theorem (flavour, name, ty, bo) -> + | CicNotationPt.Theorem (flavour, name, ty, bo) -> let attrs = [`Flavour flavour] in let ty' = interpretate_term [] env None false ty in (match bo with @@ -495,9 +534,9 @@ let rec domain_rev_of_term ?(loc = dummy_floc) context = function let outtype_dom = domain_rev_of_term_option loc context outtype in let get_first_constructor = function | [] -> [] - | ((head, _), _) :: _ -> [ Id head ] + | ((head, _, _), _) :: _ -> [ Id head ] in - let do_branch ((head, args), term) = + let do_branch ((head, _, args), term) = let (term_context, args_domain) = List.fold_left (fun (cont, dom) (name, typ) -> @@ -515,7 +554,7 @@ let rec domain_rev_of_term ?(loc = dummy_floc) context = function branches_dom @ outtype_dom @ term_dom @ (match indty_ident with | None -> get_first_constructor branches - | Some ident -> [ Id ident ]) + | Some (ident, _) -> [ Id ident ]) | CicNotationPt.Cast (term, ty) -> let term_dom = domain_rev_of_term ~loc context term in let ty_dom = domain_rev_of_term ~loc context ty in @@ -546,7 +585,7 @@ let rec domain_rev_of_term ?(loc = dummy_floc) context = function where_dom @ defs_dom | CicNotationPt.Ident (name, subst) -> (try - let index = find_in_environment name context in + let index = find_in_context name context in if subst <> None then CicNotationPt.fail loc "Explicit substitutions not allowed here" else @@ -585,12 +624,12 @@ let domain_of_obj ~context ast = assert (context = []); let domain_rev = match ast with - | GrafiteAst.Theorem (_,_,ty,bo) -> + | CicNotationPt.Theorem (_,_,ty,bo) -> (match bo with None -> [] | Some bo -> domain_rev_of_term [] bo) @ domain_of_term [] ty - | GrafiteAst.Inductive (params,tyl) -> + | CicNotationPt.Inductive (params,tyl) -> let dom = List.flatten ( List.rev_map @@ -610,7 +649,7 @@ let domain_of_obj ~context ast = not ( List.exists (fun (name',_) -> name = Id name') params || List.exists (fun (name',_,_,_) -> name = Id name') tyl) ) dom - | GrafiteAst.Record (params,_,ty,fields) -> + | CicNotationPt.Record (params,_,ty,fields) -> let dom = List.flatten (List.rev_map (fun (_,ty) -> domain_rev_of_term [] ty) fields) in @@ -641,13 +680,14 @@ module type Disambiguator = sig val disambiguate_term : ?fresh_instances:bool -> - dbd:Mysql.dbd -> + dbd:HMysql.dbd -> context:Cic.context -> metasenv:Cic.metasenv -> ?initial_ugraph:CicUniv.universe_graph -> - aliases:aliases -> (* previous interpretation status *) + aliases:DisambiguateTypes.environment ->(* previous interpretation status *) + universe:DisambiguateTypes.multiple_environment option -> CicNotationPt.term -> - (environment * (* new interpretation status *) + ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * Cic.metasenv * (* new metasenv *) Cic.term* CicUniv.universe_graph) list * (* disambiguated term *) @@ -655,11 +695,12 @@ sig val disambiguate_obj : ?fresh_instances:bool -> - dbd:Mysql.dbd -> - aliases:aliases -> (* previous interpretation status *) + dbd:HMysql.dbd -> + aliases:DisambiguateTypes.environment ->(* previous interpretation status *) + universe:DisambiguateTypes.multiple_environment option -> uri:UriManager.uri option -> (* required only for inductive types *) - GrafiteAst.obj -> - (environment * (* new interpretation status *) + CicNotationPt.obj -> + ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * Cic.metasenv * (* new metasenv *) Cic.obj * CicUniv.universe_graph) list * (* disambiguated obj *) @@ -669,7 +710,7 @@ end module Make (C: Callbacks) = struct let choices_of_id dbd id = - let uris = MetadataQuery.locate ~dbd id in + let uris = Whelp.locate ~dbd id in let uris = match uris with | [] -> @@ -691,36 +732,37 @@ module Make (C: Callbacks) = try CicUtil.term_of_uri uri with exn -> - debug_print (UriManager.string_of_uri uri); - debug_print (Printexc.to_string exn); + debug_print (lazy (UriManager.string_of_uri uri)); + debug_print (lazy (Printexc.to_string exn)); assert false in fun _ _ _ -> term)) uris +let refine_profiler = HExtlib.profile "disambiguate_thing.refine_thing" + let disambiguate_thing ~dbd ~context ~metasenv - ?(initial_ugraph = CicUniv.empty_ugraph) ~aliases + ?(initial_ugraph = CicUniv.empty_ugraph) ~aliases ~universe ~uri ~pp_thing ~domain_of_thing ~interpretate_thing ~refine_thing thing = - debug_print "DISAMBIGUATE INPUT"; - let current_env, multi_aliases_env = - match aliases with - | false, e -> Environment.hd e, None - | true, e -> Environment.empty, Some e - in + debug_print (lazy "DISAMBIGUATE INPUT"); let disambiguate_context = (* cic context -> disambiguate context *) List.map (function None -> Cic.Anonymous | Some (name, _) -> name) context in - debug_print ("TERM IS: " ^ (pp_thing thing)); + debug_print (lazy ("TERM IS: " ^ (pp_thing thing))); let thing_dom = domain_of_thing ~context:disambiguate_context thing in - debug_print (sprintf "DISAMBIGUATION DOMAIN: %s" - (string_of_domain thing_dom)); - debug_print (sprintf "DISAMBIGUATION ENVIRONMENT: %s" - (DisambiguatePp.pp_environment (snd aliases))); + debug_print (lazy (sprintf "DISAMBIGUATION DOMAIN: %s" + (string_of_domain thing_dom))); +(* + debug_print (lazy (sprintf "DISAMBIGUATION ENVIRONMENT: %s" + (DisambiguatePp.pp_environment aliases))); + debug_print (lazy (sprintf "DISAMBIGUATION UNIVERSE: %s" + (match universe with None -> "None" | Some _ -> "Some _"))); +*) let current_dom = - Environment.fold (fun item _ dom -> item :: dom) current_env [] + Environment.fold (fun item _ dom -> item :: dom) aliases [] in let todo_dom = domain_diff thing_dom current_dom in (* (2) lookup function for any item (Id/Symbol/Num) *) @@ -733,18 +775,22 @@ module Make (C: Callbacks) = | Id id -> choices_of_id dbd id | Symbol (symb, _) -> List.map DisambiguateChoices.mk_choice - (CicNotationRew.lookup_interpretations symb) + (TermAcicContent.lookup_interpretations symb) | Num instance -> DisambiguateChoices.lookup_num_choices () in - match multi_aliases_env with + match universe with | None -> lookup_in_library () | Some e -> (try + let item = + match item with + | Symbol (symb, _) -> Symbol (symb, 0) + | item -> item + in Environment.find item e - with Not_found -> lookup_in_library ()) + with Not_found -> []) in - if choices = [] then raise (No_choices item); choices in (* @@ -756,8 +802,8 @@ module Make (C: Callbacks) = (fun dom_item -> try let len = List.length (lookup_choices dom_item) in - debug_print (sprintf "BENCHMARK %s: %d" - (string_of_domain_item dom_item) len); + debug_print (lazy (sprintf "BENCHMARK %s: %d" + (string_of_domain_item dom_item) len)); len with No_choices _ -> 0) thing_dom @@ -774,7 +820,7 @@ module Make (C: Callbacks) = (* (3) test an interpretation filling with meta uninterpreted identifiers *) - let test_env current_env todo_dom ugraph = + let test_env aliases todo_dom ugraph = let filled_env = List.fold_left (fun env item -> @@ -783,66 +829,114 @@ module Make (C: Callbacks) = (match item with | Id _ | Num _ -> (fun _ _ _ -> Cic.Implicit (Some `Closed)) | Symbol _ -> (fun _ _ _ -> Cic.Implicit None))) env) - current_env todo_dom + aliases todo_dom in try + let localization_tbl = Cic.CicHash.create 503 in let cic_thing = interpretate_thing ~context:disambiguate_context ~env:filled_env - ~uri ~is_path:false thing + ~uri ~is_path:false thing ~localization_tbl + in +let foo () = + let k,ugraph1 = + refine_thing metasenv context uri cic_thing ugraph ~localization_tbl in - let k,ugraph1 = refine_thing metasenv context uri cic_thing ugraph in (k , ugraph1 ) +in refine_profiler.HExtlib.profile foo () with - | Try_again -> Uncertain, ugraph - | Invalid_choice -> Ko, ugraph + | Try_again msg -> Uncertain (None,msg), ugraph + | Invalid_choice msg -> Ko (None,msg), ugraph in (* (4) build all possible interpretations *) - let rec aux current_env todo_dom base_univ = + let (@@) (l1,l2) (l1',l2') = l1@l1', l2@l2' in + let rec aux aliases diff lookup_in_todo_dom todo_dom base_univ = match todo_dom with | [] -> - (match test_env current_env [] base_univ with + assert (lookup_in_todo_dom = None); + (match test_env aliases [] base_univ with | Ok (thing, metasenv),new_univ -> - [ current_env, metasenv, thing, new_univ ] - | Ko,_ | Uncertain,_ -> []) + [ aliases, diff, metasenv, thing, new_univ ], [] + | Ko (loc,msg),_ | Uncertain (loc,msg),_ -> [],[loc,msg]) | item :: remaining_dom -> - debug_print (sprintf "CHOOSED ITEM: %s" - (string_of_domain_item item)); - let choices = lookup_choices item in - let rec filter univ = function - | [] -> [] - | codomain_item :: tl -> - debug_print (sprintf "%s CHOSEN" (fst codomain_item)) ; - let new_env = - Environment.add item codomain_item current_env - in - (match test_env new_env remaining_dom univ with - | Ok (thing, metasenv),new_univ -> - (match remaining_dom with - | [] -> [ new_env, metasenv, thing, new_univ ] - | _ -> aux new_env remaining_dom new_univ )@ - filter univ tl - | Uncertain,new_univ -> - (match remaining_dom with - | [] -> [] - | _ -> aux new_env remaining_dom new_univ )@ - filter univ tl - | Ko,_ -> filter univ tl) - in - filter base_univ choices + debug_print (lazy (sprintf "CHOOSED ITEM: %s" + (string_of_domain_item item))); + let choices = + match lookup_in_todo_dom with + None -> lookup_choices item + | Some choices -> choices in + match choices with + [] -> + [], [None,lazy ("No choices for " ^ string_of_domain_item item)] + | [codomain_item] -> + (* just one choice. We perform a one-step look-up and + if the next set of choices is also a singleton we + skip this refinement step *) + debug_print(lazy (sprintf "%s CHOSEN" (fst codomain_item))); + let new_env = Environment.add item codomain_item aliases in + let new_diff = (item,codomain_item)::diff in + let lookup_in_todo_dom,next_choice_is_single = + match remaining_dom with + [] -> None,false + | he::_ -> + let choices = lookup_choices he in + Some choices,List.length choices = 1 + in + if next_choice_is_single then + aux new_env new_diff lookup_in_todo_dom remaining_dom + base_univ + else + (match test_env new_env remaining_dom base_univ with + | Ok (thing, metasenv),new_univ -> + (match remaining_dom with + | [] -> + [ new_env, new_diff, metasenv, thing, new_univ ], [] + | _ -> + aux new_env new_diff lookup_in_todo_dom + remaining_dom new_univ) + | Uncertain (loc,msg),new_univ -> + (match remaining_dom with + | [] -> [], [loc,msg] + | _ -> + aux new_env new_diff lookup_in_todo_dom + remaining_dom new_univ) + | Ko (loc,msg),_ -> [], [loc,msg]) + | _::_ -> + let rec filter univ = function + | [] -> [],[] + | codomain_item :: tl -> + debug_print(lazy (sprintf "%s CHOSEN" (fst codomain_item))); + let new_env = Environment.add item codomain_item aliases in + let new_diff = (item,codomain_item)::diff in + (match test_env new_env remaining_dom univ with + | Ok (thing, metasenv),new_univ -> + (match remaining_dom with + | [] -> [ new_env, new_diff, metasenv, thing, new_univ ], [] + | _ -> aux new_env new_diff None remaining_dom new_univ + ) @@ + filter univ tl + | Uncertain (loc,msg),new_univ -> + (match remaining_dom with + | [] -> [],[loc,msg] + | _ -> aux new_env new_diff None remaining_dom new_univ + ) @@ + filter univ tl + | Ko (loc,msg),_ -> ([],[loc,msg]) @@ filter univ tl) + in + filter base_univ choices in let base_univ = initial_ugraph in try let res = - match aux current_env todo_dom base_univ with - | [] -> raise NoWellTypedInterpretation - | [ e,me,t,u ] -> - debug_print "SINGLE INTERPRETATION"; - [ e,me,t,u ], false - | l -> - debug_print (sprintf "MANY INTERPRETATIONS (%d)" (List.length l)); + match aux aliases [] None todo_dom base_univ with + | [],errors -> raise (NoWellTypedInterpretation errors) + | [_,diff,metasenv,t,ugraph],_ -> + debug_print (lazy "SINGLE INTERPRETATION"); + [diff,metasenv,t,ugraph], false + | l,_ -> + debug_print (lazy (sprintf "MANY INTERPRETATIONS (%d)" (List.length l))); let choices = List.map - (fun (env, _, _, _) -> + (fun (env, _, _, _, _) -> List.map (fun domain_item -> let description = @@ -853,70 +947,34 @@ module Make (C: Callbacks) = l in let choosed = C.interactive_interpretation_choice choices in - (List.map (List.nth l) choosed), true + (List.map (fun n->let _,d,m,t,u= List.nth l n in d,m,t,u) choosed), + true in -(* - (if benchmark then - let res_size = List.length res in - debug_print (sprintf - ("BENCHMARK: %d/%d refinements performed, domain size %d, interps %d, k %.2f\n" ^^ - "BENCHMARK: estimated %.2f") - !actual_refinements !max_refinements !domain_size res_size - !choices_avg - (float_of_int (!domain_size - 1) *. !choices_avg *. (float_of_int res_size) +. !choices_avg))); -*) - let choices, b = res in - (List.map - (fun (env, metasenv, t, ugraph) -> - Environment.fold Environment.cons env (snd aliases), - metasenv, t, ugraph) - choices), - b + res with CicEnvironment.CircularDependency s -> failwith "Disambiguate: circular dependency" let disambiguate_term ?(fresh_instances=false) ~dbd ~context ~metasenv - ?(initial_ugraph = CicUniv.empty_ugraph) ~aliases term + ?(initial_ugraph = CicUniv.empty_ugraph) ~aliases ~universe term = let term = if fresh_instances then CicNotationUtil.freshen_term term else term in disambiguate_thing ~dbd ~context ~metasenv ~initial_ugraph ~aliases - ~uri:None ~pp_thing:CicNotationPp.pp_term + ~universe ~uri:None ~pp_thing:CicNotationPp.pp_term ~domain_of_thing:domain_of_term ~interpretate_thing:interpretate_term ~refine_thing:refine_term term - let disambiguate_obj ?(fresh_instances=false) ~dbd ~aliases ~uri obj = + let disambiguate_obj ?(fresh_instances=false) ~dbd ~aliases ~universe ~uri + obj + = let obj = if fresh_instances then CicNotationUtil.freshen_obj obj else obj in - disambiguate_thing ~dbd ~context:[] ~metasenv:[] ~aliases ~uri - ~pp_thing:GrafiteAstPp.pp_obj ~domain_of_thing:domain_of_obj + disambiguate_thing ~dbd ~context:[] ~metasenv:[] ~aliases ~universe ~uri + ~pp_thing:CicNotationPp.pp_obj ~domain_of_thing:domain_of_obj ~interpretate_thing:interpretate_obj ~refine_thing:refine_obj obj end -module Trivial = -struct - exception Ambiguous_term of string - exception Exit - module Callbacks = - struct - let interactive_user_uri_choice ~selection_mode ?ok - ?(enable_button_for_non_vars = true) ~title ~msg ~id uris = - raise Exit - let interactive_interpretation_choice interp = raise Exit - let input_or_locate_uri ~(title:string) ?id = raise Exit - end - module Disambiguator = Make (Callbacks) - let disambiguate_string ~dbd ?(context = []) ?(metasenv = []) ?initial_ugraph - ?(aliases = DisambiguateTypes.Environment.empty) term - = - let ast = CicNotationParser.parse_level2_ast (Stream.of_string term) in - try - fst (Disambiguator.disambiguate_term ~dbd ~context ~metasenv ast - ?initial_ugraph ~aliases:(false, aliases)) - with Exit -> raise (Ambiguous_term term) -end -