Commits

Sébastien Ferré committed 6ce565d

Richer presentation of completions (relaxed?red:green, support)

  • Participants
  • Parent commits 0c5bd38

Comments (0)

Files changed (4)

 class entry_feature ?(full = true) ?pack () =
   let box = GPack.hbox ~spacing:8 ?packing:pack () in
   let opt pack = if full then Some pack else None in
-  (* custom entry and completions *)
-  let _ = GMisc.label ~text:"Search" ?packing:(opt (fun w -> box#pack w)) () in
-  let entry_custom = GEdit.entry (*~width_chars:30*) ~packing:(box#pack ~expand:true) () in
-  let cols_completion = new GTree.column_list in
-  let markup = cols_completion#add string in
-  let feature = cols_completion#add string in
-  let model_completion = GTree.list_store cols_completion in
-  let entry_custom_completion = GEdit.entry_completion ~model:model_completion ~minimum_key_length:1 ~entry:entry_custom () in
   (* menus *)
   let menubar = GMenu.menu_bar ~packing:box#pack () in
   let menubar_factory = new GMenu.factory menubar in
-  (* creating and inserting new resources *)
-  let menu_create = menubar_factory#add_submenu "Create" in
-  let menu_create_factory = new GMenu.factory menu_create in
-  let item_var = menu_create_factory#add_item "a variable" in
-  let item_uri = menu_create_factory#add_item "an entity" in
-  let item_class = menu_create_factory#add_item "a class (a ...)" in
-  let item_prop = menu_create_factory#add_item "a property (... ?)" in
-  let item_prop_inv = menu_create_factory#add_item "an inverse property (is ... of ?)" in
-  let _ = menu_create_factory#add_separator () in
-  let item_plain = menu_create_factory#add_item "a text" in
-  let item_date = menu_create_factory#add_item "a date (yyyy-mm-dd)" in
-  let item_dateTime = menu_create_factory#add_item "a date and time (yyyy-mm-ddThh:mm:ss)" in
-  let item_file = menu_create_factory#add_item "a filename (file:///...)" in
-  let item_struct = menu_create_factory#add_item "a structure (...(...))" in
   (* transformations *)
   let menu_apply = menubar_factory#add_submenu "Apply" in
   let menu_apply_factory = new GMenu.factory menu_apply in
   let item_name = menu_apply_factory#add_item "Name" in
   let item_describe = menu_apply_factory#add_item "Describe" in
   let item_select = menu_apply_factory#add_item "Select" in
+  let item_delete = menu_apply_factory#add_item "Delete" in
+  (* creating and inserting new resources *)
+  let menu_create = menubar_factory#add_submenu "Create" in
+  let menu_create_factory = new GMenu.factory menu_create in
+  let item_var = menu_create_factory#add_item "a variable" in
+  let item_uri = menu_create_factory#add_item "an entity" in
+  let item_class = menu_create_factory#add_item "a class (a ...)" in
+  let item_prop = menu_create_factory#add_item "a property (... ?)" in
+  let item_prop_inv = menu_create_factory#add_item "an inverse property (is ... of ?)" in
+  let _ = menu_create_factory#add_separator () in
+  let item_plain = menu_create_factory#add_item "a text" in
+  let item_date = menu_create_factory#add_item "a date (yyyy-mm-dd)" in
+  let item_dateTime = menu_create_factory#add_item "a date and time (yyyy-mm-ddThh:mm:ss)" in
+  let item_file = menu_create_factory#add_item "a filename (file:///...)" in
+  let item_struct = menu_create_factory#add_item "a structure (...(...))" in
+  (* custom entry and completions *)
+(*  let _ = GMisc.label ~text:"Search" ?packing:(opt (fun w -> box#pack w)) () in *)
+  let entry_custom = GEdit.entry ~width_chars:30 ~packing:(box#pack ~expand:true) () in
+  let cols_completion = new GTree.column_list in
+  let markup = cols_completion#add string in
+  let feature = cols_completion#add string in
+  let bgcolor = cols_completion#add string in
+  let model_completion = GTree.list_store cols_completion in
+  let entry_custom_completion = GEdit.entry_completion ~model:model_completion ~minimum_key_length:1 ~entry:entry_custom () in
   (* button toolbar *)
-  let toolbar = GButton.toolbar ~orientation:`HORIZONTAL (*~style:`ICONS*) ~width:40 ~packing:box#pack ~show:(not full) () in
-  let button_delete = GButton.tool_button (*~label:"Delete"*) ~stock:`CANCEL (*~expand:true*)
+  let toolbar = GButton.toolbar ~orientation:`HORIZONTAL (*~style:`ICONS*) ~width:50 ~packing:box#pack ~show:(not full) () in
+  let button_delete = GButton.tool_button (*~label:"Delete"*) ~stock:`DELETE (* `CANCEL *) (*~expand:true*)
       ~packing:(fun item -> toolbar#insert item) () in
   object (self)
     val mutable callbacks = new entry_feature_callbacks
       refresh_widget item_name insert_s1;
       refresh_widget_transf item_describe Describe;
       refresh_widget_transf item_select Select;
+      refresh_widget_transf item_delete Delete;
       if not full then refresh_widget_transf button_delete Delete
       
     method input mode () =
     method private set_model_completion =
       Tarpit.effect (fun obs -> Common.prof "Gui.entry_feature#set_model_completion" (fun () ->
 	let key = entry_custom#text in
-	let sorted_names = history#current#place#completions ~nb_more_relax:relative_rank key in
+	let partial, relaxed, sorted_features = history#current#place#completions ~nb_more_relax:relative_rank key in
 	feat_custom <- "";
 	entry_custom_completion#misc#freeze_notify ();
 	Hashtbl.clear h_features;
 	model_completion#clear ();
 	List.iter
-	  (fun (d, sd, s, f) ->
+	  (fun (supp_opt,f) ->
+	    let s = f#string in
+	    let d = f#display ~obs in
+	    let d =
+	      match supp_opt with
+	      | None -> d
+	      | Some (a,b) -> `Kwd ("(" ^ string_of_int a ^ ")") :: `Space :: d in
 	    Hashtbl.add h_features s f;
 	    let iter = model_completion#append () in
 	    model_completion#set ~row:iter ~column:markup (make_markup d);
-	    model_completion#set ~row:iter ~column:feature s)
-	  sorted_names);
-	entry_custom_completion#misc#thaw_notify ())
+	    model_completion#set ~row:iter ~column:feature s;
+	    model_completion#set ~row:iter ~column:bgcolor (if relaxed then str_color_update else str_color_query))
+	  sorted_features;
+	if partial then begin
+	  let iter = model_completion#append () in
+	  model_completion#set ~row:iter ~column:markup "..."
+	end;
+	entry_custom_completion#misc#thaw_notify ()))
 
     initializer
       (* creation of features *)
 	(fun () -> callbacks#transf Lisql.Transf.Describe);
       item_select # connect # activate ~callback:
 	(fun () -> callbacks#transf Lisql.Transf.Select);
+      item_delete # connect # activate ~callback:
+	(fun () -> callbacks#transf Lisql.Transf.Delete);
       button_delete # connect # clicked ~callback:
 	(fun () -> callbacks#transf Lisql.Transf.Delete);
       (* completions *)
       let renderer = GTree.cell_renderer_text [] in
       entry_custom_completion#pack renderer;
       entry_custom_completion#add_attribute renderer "markup" markup;
+      entry_custom_completion#add_attribute renderer "background" bgcolor;
       ignore (entry_custom#connect#changed ~callback:(fun () ->
 	self#set_model_completion));
       entry_custom#event#connect#key_press ~callback:(fun key ->
 		    else if String.length pre >= 2 && pre.[0] = '?' && pre.[1] <> ' ' then s, ""
 		    else pre, s in
 *)
-		  let x = Hashtbl.find h_features s in
-		  callbacks#insert Logui.uri_CompletionSelection x;
-		  entry_custom#set_text "";
-		  relative_rank <- 0;
-		  true));
+		  try
+		    let x = Hashtbl.find h_features s in
+		    callbacks#insert Logui.uri_CompletionSelection x;
+		    entry_custom#set_text "";
+		    relative_rank <- 0;
+		    true
+		  with _ -> (* ... selected *)
+		    false));
       entry_custom # set_completion entry_custom_completion;
       entry_custom # connect # activate ~callback:(self#input Default);
       tooltips#set_tip entry_custom#coerce
 	~text:"Expand the name at current focus with its description";
       tooltips#set_tip item_select#coerce
 	~text:"Set the current query focus as the whole query";
+      tooltips#set_tip item_delete#coerce
+	~text:"Delete the current query focus";
       tooltips#set_tip button_delete#coerce
 	~text:"Delete the current query focus";
   end
 	[] ext
 
 
-    val restrictions_view : ((Display.t * string * string * Feature.feature) list * (Ext.t * Ext.t * Ext.t * Ext.t)) Tarpit.incremental_view =
+    val features_view : (Feature.feature list * (Ext.t * Ext.t * Ext.t * Ext.t)) Tarpit.incremental_view =
       new Tarpit.incremental_view ([], (Ext.empty, Ext.empty, Ext.empty, Ext.empty))
-    method restrictions ~obs =
-      fst (restrictions_view#contents ~obs)
+    method features ~obs =
+      fst (features_view#contents ~obs)
     initializer
       let q_name =
 	Not (role Bwd Rdfs.uri_label)
       let q_class = has_type Rdfs.uri_Class in
       let q_prop = has_type Rdf.uri_Property in
       let q_funct = has_type Term.uri_Functor (*role Bwd Term.uri_functor*) in
-      restrictions_view#define
-	(fun obs (lr0, (ext_name0, ext_class0, ext_prop0, ext_funct0)) -> Common.prof "Lisql.restrictions" (fun () ->
+      features_view#define
+	(fun obs (lf0, (ext_name0, ext_class0, ext_prop0, ext_funct0)) -> Common.prof "Lisql.features" (fun () ->
 	  let ext_name : Ext.t = self#tab_extent ~obs q_name in
 	  let ext_class : Ext.t = self#tab_extent ~obs q_class in
 	  let ext_prop : Ext.t = self#tab_extent ~obs q_prop in
 	  let delta_class = Ext.diff ext_class ext_class0 in
 	  let delta_prop = Ext.diff ext_prop ext_prop0 in
 	  let delta_funct = Ext.diff ext_funct ext_funct0 in
-	  let lf = [] in
+	  let lf = lf0 in
 	  let lf : Feature.feature list =
 	    Ext.fold
 	      (fun lf o ->
 		      lf
 		| _ -> lf)
 	      lf delta_funct in
-	  let lr =
-	    List.fold_left
-	      (fun lr f -> 
-		let d = f#display ~obs in
-		(d, Display.to_string d, f#string, f) :: lr)
-	      lr0 lf in
-(*
-	  let lr =
-	    List.fold_left
-	      (fun lr c ->
-		let pre = Pretty.print_to_string_indent (self#preview_class ~obs ~focus:None) c in
-		let s = Syntax.string_of_class c in
-		(pre, s, `P1 c)::lr)
-	      lr0 lc in
-	  let lr =
-	    List.fold_left
-	      (fun lr n ->
-		if Name.is_blank n
-		then
-		  let np = self#description ~obs n in
-		  let pre = Pretty.print_to_string_indent (Pretty.print_s1 ~obs self ~focus:None) np in
-		  let s = Syntax.print_to_string Syntax.print_s1 np in
-		  (pre, s, `Blank (n,np))::lr
-		else
-		  let pre = Pretty.print_to_string_indent (Pretty.print_name ~obs self) n in
-		  let s = Syntax.print_to_string Syntax.print_name n in
-		  (pre, s, `Name n)::lr)
-	      lr ln in
-*)
-	  lr, (ext_name, ext_class, ext_prop, ext_funct)))
+	  lf, (ext_name, ext_class, ext_prop, ext_funct)))
 
     method place ~obs (foc : focus) = new place ~obs self foc
 

src/lisql_concept.ml

     method increment_p12 (rank : int) =
       new increment_p12 ~obs store self rank
 
-    method completions (rank : int) ?(max_compl = 10) ?(nb_more_relax = 0) key : (Lisql_display.t * string * string * Feature.feature) list =
+    method completions (rank : int) ?(max_compl = 10) ?(nb_more_relax = 0) key : bool (* partial *) * bool (* relaxed *) * (supp option * Feature.feature) list =
       Common.prof "Lisql_concept.concept#completions" (fun () ->
 	let matcher =
 	  let matches str re =
 		else
 		  match ns with
 		  | [] -> None
-		  | (d,sd,s,f)::ns1 ->
+		  | (_,_,f as sdsf)::ns1 ->
 		      if i = max_compl then
 			Some (ns1, i, true, res)
-		      else if Option.fold
-			  (fun rank -> not (is_empty_supp (self#in_ext rank (f#oids ~obs))))
-			  true rank_opt then
-			Some (ns1, i+1, partial, (d,sd,s,f)::res)
 		      else
-			Some (ns1, i, partial, res))
+			let f_oids = f#oids ~obs in
+			let supp_opt = Option.map (fun rank -> self#in_ext rank f_oids) rank_opt in
+			if Option.fold
+			    (fun supp -> not (is_empty_supp supp))
+			    true supp_opt
+			then
+			  Some (ns1, i+1, partial, (supp_opt,sdsf)::res)
+			else
+			  Some (ns1, i, partial, res))
 	      (matching_names, 0, false, []) in
 	  if res <> [] || rank_opt = None then
-	    List.length res < List.length matching_names (* partial *), res
+	    List.length res < List.length matching_names (* partial *), rank_opt <> Some 0, res
 	  else
 	    let rank_opt' = Option.fold (fun rank -> self#rank_succ rank) None rank_opt in
 	    completions_aux ~obs matching_names rank_opt'
 	in
-	let names = store#restrictions ~obs in
+	let all_features = store#features ~obs in
 	let all_matching_names =
-	  List.filter
-	    (fun (d,sd,s,_) -> matcher key (sd ^ s))
-	    names in
+	  Common.mapfilter
+	    (fun f ->
+	      let sd, s = f#display_string ~obs, f#string in
+	      if matcher key (sd ^ s)
+	      then Some (sd,s,f)
+	      else None)
+	    all_features in
+	let partial, relaxed, matching_names =
+	  if all_matching_names = []
+	  then false, false, []
+	  else completions_aux ~obs all_matching_names (Some (rank + nb_more_relax)) in
+(*
 	let partial, matching_names =
 	  if all_matching_names = []
 	  then false, []
 			else Some (d, rank_opt', pm'))
 		(nb_more_relax, rank0_opt, pm0) in
 	    pm in
+*)
 	let sorted_names =
 	  List.sort
-	    (fun (_,sd1,_,_) (_,sd2,_,_) ->
+	    (fun (_,(sd1,s1,f1)) (_,(sd2,s2,f2)) ->
 	      Pervasives.compare (String.length sd1, sd1) (String.length sd2, sd2))
 	    matching_names in
+	let sorted_features = List.map (fun (supp_opt,(_,_,f)) -> (supp_opt,f)) sorted_names in
+	partial, relaxed, sorted_features)
+(*
 	if partial
-	then sorted_names @ [([`Kwd "..."], "...", "", new Feature.feature_thing store)]
+	then sorted_names @ [([`Kwd "..."], "...", "", new Feature.feature_thing store, None, None)]
 	else sorted_names)
+*)
 
   end
 

src/lisql_feature.ml

 
 
 class virtual feature =
-  object
+  object (self)
     method virtual kind : kind
     method virtual spec : spec
     method virtual string : string
     method virtual display : obs:Tarpit.observer -> Display.t
+    method display_string : obs:Tarpit.observer -> string = fun ~obs -> Display.to_string (self#display ~obs)
     method uri_opt : Uri.t option = None
     method prop_uri_opt : Uri.t option = None
     method name_opt : Name.t option = None