Commits

Sébastien Ferré  committed 80ce193

Use of displays instead of names in cube for better display.

  • Participants
  • Parent commits 3dea3df

Comments (0)

Files changed (3)

 
     method refresh = Common.prof "Gui.text_query#refresh" (fun () ->
       let focus_mark = ref None in
-(*
-      let rec print = function
-	| [] -> ()
-	| Lisql.Pretty.Tag (x, l1)::l ->
-	    let start_offset = buffer#end_iter#offset in
-	    print l1;
-	    let end_offset = buffer#end_iter#offset in
-	    let tag_opt =
-	      match x with
-	      | Lisql.Pretty.Tag_class -> Some tag_class
-	      | Lisql.Pretty.Tag_property -> Some tag_property
-	      | Lisql.Pretty.Tag_functor -> Some tag_functor
-	      | Lisql.Pretty.Tag_entity -> Some tag_entity
-	      | Lisql.Pretty.Tag_literal -> Some tag_literal
-	      | Lisql.Pretty.Tag_variable -> Some tag_variable
-	      | Lisql.Pretty.Tag_focus foc ->
-		  Hashtbl.add h_foc_offsets foc (start_offset, end_offset);
-		  if Lisql.AST.same_focus foc history#current#focus
-		  then
-		    Some 
-		      (if history#current#extents#rank = 0 && history#current#extents#current#nbobj <> 0
-		      then tag_query
-		      else tag_update)
-		  else None in
-	    Option.iter
-	      (fun tag ->
-		buffer#apply_tag tag ~start:(buffer#get_iter (`OFFSET start_offset)) ~stop:buffer#end_iter)
-	      tag_opt;
-	    print l
-	| Lisql.Pretty.Str s::l ->
-	    buffer#insert s;
-	    print l
-	| Lisql.Pretty.Image uri::l ->
-	    begin
-	      try buffer # insert_pixbuf ~iter:buffer#end_iter ~pixbuf:(pixbuf_of_picture ~maxside:100 uri)
-	      with _ -> () (* in case the picture cannot be found *)
-	    end;
-	    print l
-	| Lisql.Pretty.Focus::l ->
-	    focus_mark := Some (buffer#create_mark buffer#end_iter);
-	    let focus_anchor = buffer#create_child_anchor buffer#end_iter in
-	    view#add_child_at_anchor focus_box#coerce focus_anchor;
-	    print l
-      in
-*)
       Tarpit.effect (fun obs ->
 	Hashtbl.clear h_foc_offsets;
 	focus_box#remove focus_widget#coerce;
 	focus_box#add focus_widget#coerce;
 	buffer # set_text "";
 	Lisql.Display.markup
-	  true
+	  false
 	  (display_ctx_query buffer h_foc_offsets focus_mark view focus_box)
 	  (Lisql.Display.of_s ~obs history#store history#current#assertion);
-(*
-	print
-	  (if edit_mode
-	  then [Lisql.Pretty.Str (Lisql.Syntax.string_of_assertion history#current#assertion)]
-	  else preview_of_assertion_indent_with_tags ~obs (history#current#assertion, history#current#focus));
-	if edit_mode then buffer # insert " ";
-*)
 	buffer # apply_tag tag_scale_up ~start:buffer#start_iter ~stop:buffer#end_iter;
 	Option.iter (fun mark -> view#scroll_to_mark (`MARK mark)) !focus_mark;
 	focus_widget#grab_focus ()))
     method refresh_contents =
       List.iter ~f:(fun w -> if not (self#mem_persistent_widget w) then table#remove w) table#children;
       let _ =
-	answers#fold
+	answers#fold ~obs:Tarpit.blind_observer
 	  (fun row line ->
 	    List.fold_left
-	      ~f:(fun col name_opt ->
-		let markup =
-		  match name_opt with
-		  | None -> "-"
-		  | Some name -> make_markup (Lisql.Display.of_name ~obs:Tarpit.blind_observer history#store name) in
+	      ~f:(fun col disp ->
+		let markup = make_markup disp in
 		let label_cell = GMisc.label ~markup ~xalign:0. ~yalign:0. () in
 		table#attach ~left:col ~top:row ~fill:`BOTH label_cell#coerce;
 		col+1)

File src/lisql.ml

       end)
     (0., 0) index
 
-let make_aggreg store g index : Name.t option =
+let make_null : Display.t = [`Kwd "-"]
+
+let make_aggreg ~obs store g index : Display.t =
   match g with
   | `INDEX ->
       let l_index = Intmap.fold (fun res o counter -> (!counter,o)::res) [] index in
       let sorted_l_index = List.sort (fun (c1,_) (c2,_) -> Pervasives.compare c2 c1) l_index in
         (* decreasing count *)
+      if sorted_l_index = []
+      then make_null
+      else
+	[`List (List.map
+		  (fun (c,o) ->
+		    let d_c =
+		      if c = 1
+		      then []
+		      else [`Kwd (Printf.sprintf "(%d)" c)] in
+		    let d_o =
+		      if o = 0
+		      then make_null
+		      else Display.display_name ~obs:Tarpit.blind_observer store (store#get_name o) in
+		    d_o @ `Space :: d_c)
+		  sorted_l_index)]
+(*
       ( match sorted_l_index with
       | [] -> None
       | item::items ->
 	      (if o = 0
 	      then Printf.sprintf "- (%d)" c
 	      else Printf.sprintf "%s (%d)"
-		  (Display.string_of_name ~obs:Tarpit.blind_observer store (store#get_name o))
+		  (Display.string_of_name ~obs store (store#get_name o))
 		  c) in
 	  add_item item;
 	  List.iter (fun item -> Buffer.add_char buf '\n'; add_item item) items;
 	  Some (Name.typed_literal (Buffer.contents buf) Xsd.uri_string))
+*)
   | `DISTINCT_COUNT ->
-      Some (Name.typed_literal (string_of_int (Intmap.cardinal index)) Xsd.uri_integer)
+      Display.display_name ~obs store (Name.typed_literal (string_of_int (Intmap.cardinal index)) Xsd.uri_integer)
   | `SUM ->
       let sum, count = sum_count store index in
       if count = 0
-      then None
-      else Some (Name.typed_literal (string_of_float sum) Xsd.uri_double)
+      then make_null
+      else Display.display_name ~obs store (Name.typed_literal (string_of_float sum) Xsd.uri_double)
   | `AVG ->
       let sum, count = sum_count store index in
       if count = 0
-      then None
+      then make_null
       else
 	let avg = sum /. (float_of_int count) in
-	Some (Name.typed_literal (string_of_float avg) Xsd.uri_double)
-  | _ -> None
+	Display.display_name ~obs store (Name.typed_literal (string_of_float avg) Xsd.uri_double)
+  | _ -> make_null
 
-let rec fold_answers store (offset : int ref) (limit : int ref) (cube : cube)
-    (f : 'a -> Name.t option list -> 'a) (init : 'a) (rev_line : Name.t option list) rel : 'a =
+let rec fold_answers ~obs store (offset : int ref) (limit : int ref) (cube : cube)
+    (f : 'a -> Display.t list -> 'a) (init : 'a) (rev_line : Display.t list) rel : 'a =
   match cube with
   | `COUNT sub_cube ->
       if !offset > 0 then
 	init
       else begin
 	decr limit;
-	let n_count = Name.typed_literal (string_of_int (Rel.cardinal rel)) Xsd.uri_integer in
-	let line = fold_measures store sub_cube ((Some n_count) :: rev_line) 0 rel in
+	let d_count = Display.display_name ~obs store (Name.typed_literal (string_of_int (Rel.cardinal rel)) Xsd.uri_integer) in
+	let line = fold_measures ~obs store sub_cube (d_count :: rev_line) 0 rel in
 	f init line
       end
   | `DIMENSION (filter,order,sub_cube) ->
       List.fold_left
 	(fun res (n_opt,o) ->
 	  let sub_rel = Rel.assoc o rel in
-	  fold_answers store offset limit sub_cube f res (n_opt::rev_line) sub_rel)
+	  let d_n_opt = match n_opt with None -> make_null | Some n -> Display.display_name ~obs store n in
+	  fold_answers ~obs store offset limit sub_cube f res (d_n_opt::rev_line) sub_rel)
 	init sorted_key_names
   | `HIDDEN sub_cube ->
-      fold_answers store offset limit sub_cube f init (None::rev_line) rel
-and fold_measures store cube rev_line col rel =
+      fold_answers ~obs store offset limit sub_cube f init (make_null::rev_line) rel
+and fold_measures ~obs store cube rev_line col rel =
   match cube with
   | [] -> List.rev rev_line
   | `VOID::sub_cube ->
-      fold_measures store sub_cube (None::rev_line) col rel
+      fold_measures ~obs store sub_cube (make_null::rev_line) col rel
   | `AGGREG g::sub_cube ->
       let index = index col rel in
-      let n_aggreg_opt = make_aggreg store g index in
-      fold_measures store sub_cube (n_aggreg_opt::rev_line) (col+1) rel
+      let d_aggreg = make_aggreg ~obs store g index in
+      fold_measures ~obs store sub_cube (d_aggreg::rev_line) (col+1) rel
 
 
 class answers store (lv, ext : var list * Extension.t) =
       | `INDEX -> Hashtbl.remove h_aggreg v
       | _ -> Hashtbl.replace h_aggreg v g
 
-    method fold : 'a. ('a -> Name.t option list -> 'a) -> 'a -> 'a =
-      fun f init ->
+    method fold : 'a. obs:Tarpit.observer -> ('a -> Display.t list -> 'a) -> 'a -> 'a =
+      fun ~obs f init ->
 	let offset = page_start - 1 in
 	let limit = page_size in
 	let rel = Rel.project
 	  match pre_cube with
 	  | `Measures l -> `COUNT l
 	  | `Cube c -> c in
-	fold_answers store (ref offset) (ref limit) cube f init [] rel
+	fold_answers ~obs store (ref offset) (ref limit) cube f init [] rel
 
     method copy (lv, ext : var list * Extension.t) =
       (* removing old columns *)

File src/lisql_display.ml

     | `Plain of string * string
     | `Typed of string * Uri.t * string
     | `Xml of Xml.xml
+    | `List of t list
     | `Tuple of t list
     | `And of t list
     | `Or of t list
   | `Plain (s,lang) -> "\"" ^ String.escaped s ^ "\"" ^ (if lang = "" then "" else "@" ^ lang)
   | `Typed (s, uri_dt, s_dt) -> "\"" ^ String.escaped s ^ (if s_dt = "" then "" else "\"^^" ^ s_dt)
   | `Xml xml -> Xml.to_string xml
+  | `List ltoks -> "(" ^ String.concat " " (List.map to_string ltoks) ^ ")"
   | `Tuple ltoks -> "(" ^ String.concat ", " (List.map to_string ltoks) ^ ")"
   | `And ltoks -> String.concat " and " (List.map to_string ltoks)
   | `Or ltoks -> String.concat " or " (List.map to_string ltoks)
   | `Plain _ -> true
   | `Typed _ -> true
   | `Xml _ -> false
+  | `List _ -> false
   | `Tuple ltoks -> List.for_all is_short_display ltoks
   | `And _ -> false
   | `Or _ -> false
 	List.iter (fun toks -> ctx#string ","; markup true ctx#indent toks) ltoks;
 	ctx#string ")"
       end
+  | `List [] -> assert false
+  | `List (toks::ltoks) ->
+      markup false ctx toks;
+      List.iter (fun toks -> ctx#newline; markup false ctx toks) ltoks
   | `And [] -> assert false
   | `And (toks::ltoks) ->
       markup false ctx toks;