csv.ml

   1 (* csv.ml - comma separated values parser
   2  *
   3  * $Id: csv.ml,v 1.13 2006-11-24 09:43:15 rich Exp $
   4  *)
   5
   6 (* The format of CSV files:
   7  *
   8  * Each field starts with either a double quote char or some other
   9  * char. For the some other char case things are simple: just read up
  10  * to the next comma (,) which marks the end of the field.
  11  *
  12  * In the case where a field begins with a double quote char the
  13  * parsing rules are different. Any double quotes are doubled ("") and
  14  * we finish reading when we reach an undoubled quote. eg: "The
  15  * following is a quote: "", and that's all" is the CSV equivalent of
  16  * the following literal field: The following is a quote: ", and that's
  17  * all
  18  *
  19  * "0 is the quoted form of ASCII NUL.
  20  *
  21  * CSV fields can also contain literal carriage return characters, if
  22  * they are quoted, eg: "This field
  23  * is split over lines" represents a
  24  * single field containing a \n.
  25  *
  26  * Excel will only use the quoting format if a field contains a double
  27  * quote or comma, although there's no reason why Excel couldn't always
  28  * use the quoted format.
  29  *
  30  * The practical upshot of this is that you can't split a line in a CSV
  31  * file just by looking at the commas. You need to parse each field
  32  * separately.
  33  *
  34  * How we represent CSV files:
  35  *
  36  * We load in the whole CSV file at once, and store it internally as a
  37  * 'string list list' type (note that each line in the CSV file can,
  38  * and often will, have different lengths). We then provide simple
  39  * functions to read the CSV file line-by-line, copy it out, or copy a
  40  * subset of it into a matrix.
  41  *)
  42
  43 open Printf
  44
  45 (* Uncomment the next line to enable Extlib's List function.  These
  46  * avoid stack overflows on really huge CSV files.
  47  *)
  48 (*open ExtList*)
  49
  50 type t = string list list
  51
  52 exception Bad_CSV_file of string
  53
  54 let rec dropwhile f = function
  55   | [] -> []
  56   | x :: xs when f x -> dropwhile f xs
  57   | xs -> xs
  58
  59 (* from extlib: *)
  60 let rec drop n = function
  61   | _ :: l when n > 0 -> drop (n-1) l
  62   | l -> l
  63
  64 let rec take n = function
  65   | x :: xs when n > 0 -> x :: take (pred n) xs
  66   | _ -> []
  67
  68 let lines = List.length
  69
  70 let columns csv =
  71   List.fold_left max 0 (List.map List.length csv)
  72
  73 type state_t = StartField
  74                | InUnquotedField
  75                | InQuotedField
  76                | InQuotedFieldAfterQuote
  77
  78 let load_rows ?(separator = ',') f chan =
  79   let row = ref [] in                   (* Current row. *)
  80   let field = ref [] in                 (* Current field. *)
  81   let state = ref StartField in         (* Current state. *)
  82   let end_of_field () =
  83     let field_list = List.rev !field in
  84     let field_len = List.length field_list in
  85     let field_str = String.create field_len in
  86     let rec loop i = function
  87         [] -> ()
  88       | x :: xs ->
  89           field_str.[i] <- x;
  90           loop (i+1) xs
  91     in
  92     loop 0 field_list;
  93     row := field_str :: !row;
  94     field := [];
  95     state := StartField
  96   in
  97   let empty_field () =
  98     row := "" :: !row;
  99     field := [];
 100     state := StartField
 101   in
 102   let end_of_row () =
 103     let row_list = List.rev !row in
 104     f row_list;
 105     row := [];
 106     state := StartField
 107   in
 108   let rec loop () =
 109     let c = input_char chan in
 110     if c != '\r' then (                 (* Always ignore \r characters. *)
 111       match !state with
 112           StartField ->                 (* Expecting quote or other char. *)
 113             if c = '"' then (
 114               state := InQuotedField;
 115               field := []
 116             ) else if c = separator then (* Empty field. *)
 117               empty_field ()
 118             else if c = '\n' then (     (* Empty field, end of row. *)
 119               empty_field ();
 120               end_of_row ()
 121             ) else (
 122               state := InUnquotedField;
 123               field := [c]
 124             )
 125         | InUnquotedField ->            (* Reading chars to end of field. *)
 126             if c = separator then       (* End of field. *)
 127               end_of_field ()
 128             else if c = '\n' then (     (* End of field and end of row. *)
 129               end_of_field ();
 130               end_of_row ()
 131             ) else
 132               field := c :: !field
 133         | InQuotedField ->              (* Reading chars to end of field. *)
 134             if c = '"' then
 135               state := InQuotedFieldAfterQuote
 136             else
 137               field := c :: !field
 138         | InQuotedFieldAfterQuote ->
 139             if c = '"' then (           (* Doubled quote. *)
 140               field := c :: !field;
 141               state := InQuotedField
 142             ) else if c = '0' then (    (* Quote-0 is ASCII NUL. *)
 143               field := '\000' :: !field;
 144               state := InQuotedField
 145             ) else if c = separator then (* End of field. *)
 146               end_of_field ()
 147             else if c = '\n' then (     (* End of field and end of row. *)
 148               end_of_field ();
 149               end_of_row ()
 150             ) else (                    (* Bad single quote in field. *)
 151               field := c :: '"' :: !field;
 152               state := InQuotedField
 153             )
 154     ); (* end of match *)
 155     loop ()
 156   in
 157   try
 158     loop ()
 159   with
 160       End_of_file ->
 161         (* Any part left to write out? *)
 162         (match !state with
 163              StartField ->
 164                if !row <> [] then
 165                  ( empty_field (); end_of_row () )
 166            | InUnquotedField | InQuotedFieldAfterQuote ->
 167                end_of_field (); end_of_row ()
 168            | InQuotedField ->
 169                raise (Bad_CSV_file "Missing end quote after quoted field.")
 170         )
 171
 172 let load_in ?separator chan =
 173   let csv = ref [] in
 174   let f row =
 175     csv := row :: !csv
 176   in
 177   load_rows ?separator f chan;
 178   List.rev !csv
 179
 180 let load ?separator filename =
 181   let chan = open_in filename in
 182   let csv = load_in ?separator chan in
 183   close_in chan;
 184   csv
 185
 186 let trim ?(top=true) ?(left=true) ?(right=true) ?(bottom=true) csv =
 187   let rec empty_row = function
 188     | [] -> true
 189     | x :: xs when x <> "" -> false
 190     | x :: xs -> empty_row xs
 191   in
 192   let csv = if top then dropwhile empty_row csv else csv in
 193   let csv =
 194     if right then
 195       List.map (fun row ->
 196                   let row = List.rev row in
 197                   let row = dropwhile ((=) "") row in
 198                   let row = List.rev row in
 199                   row) csv
 200     else csv in
 201   let csv =
 202     if bottom then (
 203       let csv = List.rev csv in
 204       let csv = dropwhile empty_row csv in
 205       let csv = List.rev csv in
 206       csv
 207     ) else csv in
 208
 209   let empty_left_cell =
 210     function [] -> true | x :: xs when x = "" -> true | _ -> false in
 211   let empty_left_col =
 212     List.fold_left (fun a row -> a && empty_left_cell row) true in
 213   let remove_left_col =
 214     List.map (function [] -> [] | x :: xs -> xs) in
 215   let rec loop csv =
 216     if empty_left_col csv then (
 217       let csv = remove_left_col csv in
 218       loop csv
 219     ) else csv
 220   in
 221
 222   let csv = if left then loop csv else csv in
 223
 224   csv
 225
 226 let square csv =
 227   let columns = columns csv in
 228   List.map (
 229     fun row ->
 230       let n = List.length row in
 231       let row = List.rev row in
 232       let rec loop acc = function
 233         | 0 -> acc
 234         | i -> "" :: loop acc (i-1)
 235       in
 236       let row = loop row (columns - n) in
 237       List.rev row
 238   ) csv
 239
 240 let is_square csv =
 241   let columns = columns csv in
 242   List.for_all (fun row -> List.length row = columns) csv
 243
 244 let rec set_columns cols = function
 245   | [] -> []
 246   | r :: rs ->
 247       let rec loop i cells =
 248         if i < cols then (
 249           match cells with
 250           | [] -> "" :: loop (succ i) []
 251           | c :: cs -> c :: loop (succ i) cs
 252         )
 253         else []
 254       in
 255       loop 0 r :: set_columns cols rs
 256
 257 let rec set_rows rows csv =
 258   if rows > 0 then (
 259     match csv with
 260     | [] -> [] :: set_rows (pred rows) []
 261     | r :: rs -> r :: set_rows (pred rows) rs
 262   )
 263   else []
 264
 265 let set_size rows cols csv =
 266   set_columns cols (set_rows rows csv)
 267
 268 let sub r c rows cols csv =
 269   let csv = drop r csv in
 270   let csv = List.map (drop c) csv in
 271   let csv = set_rows rows csv in
 272   let csv = set_columns cols csv in
 273   csv
 274
 275 (* Compare two rows for semantic equality - ignoring any blank cells
 276  * at the end of each row.
 277  *)
 278 let rec compare_row (row1 : string list) row2 =
 279   match row1, row2 with
 280   | [], [] -> 0
 281   | x :: xs, y :: ys ->
 282       let c = compare x y in
 283       if c <> 0 then c else compare_row xs ys
 284   | "" :: xs , [] ->
 285       compare_row xs []
 286   | x :: xs, [] ->
 287       1
 288   | [], "" :: ys ->
 289       compare_row [] ys
 290   | [], y :: ys ->
 291       -1
 292
 293 (* Semantic equality for CSV files. *)
 294 let rec compare (csv1 : t) csv2 =
 295   match csv1, csv2 with
 296   | [], [] -> 0
 297   | x :: xs, y :: ys ->
 298       let c = compare_row x y in
 299       if c <> 0 then c else compare xs ys
 300   | x :: xs, [] ->
 301       let c = compare_row x [] in
 302       if c <> 0 then c else compare xs []
 303   | [], y :: ys ->
 304       let c = compare_row [] y in
 305       if c <> 0 then c else compare [] ys
 306
 307 (* Concatenate - arrange left to right. *)
 308 let rec concat = function
 309   | [] -> []
 310   | [csv] -> csv
 311   | left_csv :: csvs ->
 312       (* Concatenate the remaining CSV files. *)
 313       let right_csv = concat csvs in
 314
 315       (* Set the height of the left and right CSVs to the same. *)
 316       let nr_rows = max (lines left_csv) (lines right_csv) in
 317       let left_csv = set_rows nr_rows left_csv in
 318       let right_csv = set_rows nr_rows right_csv in
 319
 320       (* Square off the left CSV. *)
 321       let left_csv = square left_csv in
 322
 323       (* Prepend the right CSV rows with the left CSV rows. *)
 324       List.map (
 325         fun (left_row, right_row) -> List.append left_row right_row
 326       ) (List.combine left_csv right_csv)
 327
 328 let to_array csv =
 329   Array.of_list (List.map Array.of_list csv)
 330
 331 let of_array csv =
 332   List.map Array.to_list (Array.to_list csv)
 333
 334 let associate header data =
 335   let nr_cols = List.length header in
 336   let rec trunc = function
 337     | 0, _ -> []
 338     | n, [] -> "" :: trunc (n-1, [])
 339     | n, (x :: xs) -> x :: trunc (n-1, xs)
 340   in
 341   List.map (
 342     fun row ->
 343       let row = trunc (nr_cols, row) in
 344       List.combine header row
 345   ) data
 346
 347 let save_out ?(separator = ',') chan csv =
 348   (* Quote a single CSV field. *)
 349   let quote_field field =
 350     if String.contains field separator ||
 351       String.contains field '\"' ||
 352       String.contains field '\n'
 353     then (
 354       let buffer = Buffer.create 100 in
 355       Buffer.add_char buffer '\"';
 356       for i = 0 to (String.length field) - 1 do
 357         match field.[i] with
 358             '\"' -> Buffer.add_string buffer "\"\""
 359           | c    -> Buffer.add_char buffer c
 360       done;
 361       Buffer.add_char buffer '\"';
 362       Buffer.contents buffer
 363     )
 364     else
 365       field
 366   in
 367
 368   let separator = String.make 1 separator in
 369   List.iter (fun line ->
 370                output_string chan (String.concat separator
 371                                      (List.map quote_field line));
 372                output_char chan '\n') csv
 373
 374 let print ?separator csv =
 375   save_out ?separator stdout csv; flush stdout
 376
 377 let save ?separator file csv =
 378   let chan = open_out file in
 379   save_out ?separator chan csv;
 380   close_out chan
 381
 382 let save_out_readable chan csv =
 383   (* Escape all the strings in the CSV file first. *)
 384   (* XXX Why are we doing this?  I commented it out anyway.
 385   let csv = List.map (List.map String.escaped) csv in
 386   *)
 387
 388   (* Find the width of each column. *)
 389   let widths =
 390     (* Don't consider rows with only a single element - typically
 391      * long titles.
 392      *)
 393     let csv = List.filter (function [_] -> false | _ -> true) csv in
 394
 395     (* Square the CSV file - makes the next step simpler to implement. *)
 396     let csv = square csv in
 397
 398     match csv with
 399       | [] -> []
 400       | row1 :: rest ->
 401           let lengths_row1 = List.map String.length row1 in
 402           let lengths_rest = List.map (List.map String.length) rest in
 403           let max2rows r1 r2 =
 404             let rp =
 405               try List.combine r1 r2
 406               with
 407                 Invalid_argument "List.combine" ->
 408                   failwith (sprintf "Csv.save_out_readable: internal error: length r1 = %d, length r2 = %d" (List.length r1) (List.length r2)) in
 409             List.map (fun ((a : int), (b : int)) -> max a b) rp
 410           in
 411           List.fold_left max2rows lengths_row1 lengths_rest in
 412
 413   (* Print out each cell at the correct width. *)
 414   let rec repeat f = function
 415     | 0 -> ()
 416     | i -> f (); repeat f (i-1)
 417   in
 418   List.iter (
 419     function
 420     | [cell] ->                         (* Single column. *)
 421         output_string chan cell;
 422         output_char chan '\n'
 423     | row ->                            (* Other. *)
 424         (* Pair up each cell with its max width. *)
 425         let row =
 426           let rec loop = function
 427             | ([], _) -> []
 428             | (_, []) -> failwith "Csv.save_out_readable: internal error"
 429             | (cell :: cells, width :: widths) ->
 430                 (cell, width) :: loop (cells, widths)
 431           in
 432           loop (row, widths) in
 433         List.iter (
 434           fun (cell, width) ->
 435             output_string chan cell;
 436             let n = String.length cell in
 437             repeat (fun () -> output_char chan ' ') (width - n + 1)
 438         ) row;
 439         output_char chan '\n'
 440   ) csv
 441
 442 let print_readable = save_out_readable stdout