helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/csview.ml

   1 (* $Id$ *)
   2
   3 (* A simple CSV data viewer *)
   4
   5 type data =
   6     { fields : string list;
   7       titles : string list;
   8       data : string list list }
   9
  10 let mem_string ~char s =
  11   try
  12     for i = 0 to String.length s - 1 do
  13       if s.[i] = char then raise Exit
  14     done;
  15     false
  16   with Exit -> true
  17
  18 let rec until ~chars ?(escapes="") ?(buf = Buffer.create 80) s =
  19   match Stream.peek s with
  20     Some c ->
  21       if mem_string ~char:c escapes then begin
  22         Stream.junk s;
  23         Buffer.add_char buf (Stream.next s);
  24         until ~chars ~escapes ~buf s
  25       end else if mem_string ~char:c chars then
  26         Buffer.contents buf
  27       else begin
  28         Buffer.add_char buf c;
  29         Stream.junk s;
  30         until ~chars ~escapes ~buf s
  31       end
  32   | None ->
  33       if Buffer.length buf > 0 then raise (Stream.Error "until")
  34       else raise Stream.Failure
  35
  36 let rec ignores ?(chars = " \t") s =
  37   match Stream.peek s with
  38     Some c when mem_string ~char:c chars ->
  39       Stream.junk s; ignores ~chars s
  40   | _ -> ()
  41
  42 let parse_field = parser
  43     [< ''"'; f = until ~chars:"\"" ~escapes:"\\"; ''"'; _ = ignores >] ->
  44       for i = 0 to String.length f - 1 do
  45         if f.[i] = '\031' then f.[i] <- '\n'
  46       done;
  47       f
  48   | [< f = until ~chars:",\n\r" >] -> f
  49   | [< >] -> ""
  50
  51 let comma = parser [< '','; _ = ignores >] -> ()
  52
  53 let rec parse_list ~item ~sep = parser
  54     [< i = item; s >] ->
  55       begin match s with parser
  56         [< _ = sep; l = parse_list ~item ~sep >] -> i :: l
  57       | [< >] -> [i]
  58       end
  59   | [< >] -> []
  60
  61 let parse_one = parse_list ~item:parse_field ~sep:comma
  62
  63 let lf = parser [< ''\n'|'\r'; _ = ignores ~chars:"\n\r"; _ = ignores >] -> ()
  64
  65 let parse_all = parse_list ~item:parse_one ~sep:lf
  66
  67 let read_file file =
  68   let ic = open_in file in
  69   let s = Stream.of_channel ic in
  70   let data = parse_all s in
  71   close_in ic;
  72   match data with
  73     ("i"::fields) :: ("T"::titles) :: data ->
  74       {fields=fields; titles=titles; data=List.map ~f:List.tl data}
  75   | titles :: data ->
  76       {fields=titles; titles=titles; data=data}
  77   | _ -> failwith "Insufficient data"
  78
  79 let print_string s =
  80   Format.print_char '"';
  81   for i = 0 to String.length s - 1 do
  82     match s.[i] with
  83       '\'' -> Format.print_char '\''
  84     | '"' -> Format.print_string "\\\""
  85     | '\160'..'\255' as c -> Format.print_char c
  86     | c -> Format.print_string (Char.escaped c)
  87   done;
  88   Format.print_char '"'
  89
  90 (*
  91 #install_printer print_string;;
  92 *)
  93
  94 open GMain
  95
  96 let field_widths =
  97   [ "i", 0;
  98     "ATTR", 0;
  99     "NAME", 17;
 100     "NAPR", 8;
 101     "TEL1", 14;
 102     "ZIPC", 12;
 103     "ADR1", 40;
 104     "BRTH", 10;
 105     "RMRK", 20;
 106     "CHK1", 0;
 107     "CHK2", 0;
 108     "CHK3", 0;
 109     "CHK4", 0;
 110     "TIM1", 16;
 111     "TIM2", 16;
 112     "ALRM", 0;
 113     "ATTM", 0;
 114   ]
 115
 116 let main argv =
 117   if Array.length argv <> 2 then begin
 118     prerr_endline "Usage: csview <csv file>";
 119     exit 2
 120   end;
 121   let data = read_file argv.(1) in
 122   let w = GWindow.window () in
 123   w#misc#realize ();
 124   let style = w#misc#style in
 125   let font = Gdk.Font.load_fontset "-schumacher-clean-medium-r-normal--13-*-*-*-c-60-*,-mnkaname-fixed-*--12-*" in
 126   let w0 = Gdk.Font.char_width font '0' in
 127   style#set_font font;
 128   w#connect#destroy ~callback:Main.quit;
 129   let sw = GBin.scrolled_window ~width:600 ~height:300 ~packing:w#add () in
 130   let cl = GList.clist ~titles:data.titles ~packing:sw#add () in
 131   List.fold_left data.fields ~init:0 ~f:
 132     begin fun acc f ->
 133       let width = try List.assoc f field_widths with Not_found -> -1 in
 134       if width = 0 then
 135         cl#set_column ~visibility:false acc
 136       else begin
 137         if width > 0 then cl#set_column ~width:(width * w0) acc
 138         else cl#set_column ~auto_resize:true acc;
 139         if f = "NAPR" || f = "TIM1" || f = "CLAS" then
 140           cl#set_sort ~auto:true ~column:acc ();
 141         try
 142           let ali = GBin.alignment_cast (cl#column_widget acc) in
 143           let lbl = GMisc.label_cast (List.hd ali#children) in
 144           lbl#set_alignment ~x:0. ()
 145         with _ ->
 146           prerr_endline ("No column widget for field " ^ f)
 147       end;
 148       succ acc
 149     end;
 150   List.iter data.data
 151     ~f:(fun l -> if List.length l > 1 then ignore (cl#append l));
 152   w#show ();
 153   Main.main ()
 154
 155 let _ = main Sys.argv