(**
  CSV読込みプログラム csv.ml。
  オリジナルのコードは lablgtk　のサンプルコードです。
  それを小笠原(ogasawara\@itpl.co.jp)が色々と改造したものです。
  オリジナルのコードに明確なライセンスがありませんので、このコードにも特に明確なライセンスを設けません。

  コンパイル:
    ocamlc -c -pp "camlp4o" csv.ml

  @author Satoshi Ogasawara, IT Planning Inc.
  @version $Id: csv.ml,v 1.2 2007/05/21 04:02:40 ogasawara Exp $

*)
open Printf

(* strの中にcharが含まれるか? *)
let mem_string char str =
  try
    let _ = String.index str char in
    true
  with
    Not_found -> false

(* charsに含まれる文字を見付けるまでstreamからbufに書き込み *)
let rec until ~chars ~escapes ?(buf = Buffer.create 80) =
  let next ~char ~skip ~fw ~buf strm =
    if not skip then Buffer.add_char buf char;
    for i = 1 to fw do
      Buffer.add_char buf (Stream.next strm)
    done;
    until ~chars ~escapes ~buf strm
  in
  fun (strm : _ Stream.t) ->
    match Stream.peek strm with
      (* ShiftJISへの対応 *)
      Some c when c >= '\x81' && c <= '\x9F' ->
        Stream.junk strm;
        next ~char:c ~skip:false ~fw:1 ~buf strm
    | Some c when mem_string c escapes ->
        Stream.junk strm;
        next ~char:c ~skip:true ~fw:1 ~buf strm
    | Some c when mem_string c chars -> Buffer.contents buf
    | Some c ->
        Stream.junk strm;
        next ~char:c ~skip:false ~fw:0 ~buf strm
    | _ ->
        if Buffer.length buf > 0 then Buffer.contents buf
        else raise Stream.Failure

(* charsに含まれる文字を無視 *)
let rec ignores chars = parser
    [< 'c when mem_string c chars; _ = ignores chars >] -> ()
  | [< >] -> ()

(* sepに区切られたitemをfoldしながらresultに貯めていくパーサ *)
let rec parse_list ~item ~sep fold result = parser
    [< i = item; strm >] ->
      begin match strm with parser
          [< _ = sep; rest >] -> 
	    parse_list ~item ~sep fold (fold result i) rest
	| [< >] -> (fold result i)
      end
  | [< >] -> result

(*  CSVファイルをパースする際に変更できるパラメータ *)
type params = { 
    sep : char;        (* セパレータ *)
    quote : char;      (* 文字列の括り文字 *)
    escapes : string;  (* 括り文字をエスケープする文字 *)
    ignores : string;  (* 無視する文字列 *)
  }

(* フィールドデータのパーサ *)
let parse_field param line = parser
    [< 'bq when bq = param.quote;
        field = until ~chars:"\"" ~escapes:param.escapes;
       'aq when aq = param.quote ?? (sprintf "unbalance quote in line %d" line);
        _ = ignores param.ignores
    >] -> field
  | [< field = until ~chars:(sprintf "%c\n\r" param.sep) ~escapes:param.escapes >] -> field

(* 一行のパーサ *)
let parse_line =
  let counter = ref 0 in
  fun param strm ->
    incr counter;
    let parse_sep char = parser 
	[< 'c when c = char; _ = ignores param.ignores >] -> ()
    in
    List.rev
      (parse_list 
	 ~item:(parse_field param !counter)
	 ~sep:(parse_sep param.sep)
	 (fun r l -> l :: r)
	 []
	 strm)

(** 
  csvパーサ.
  parse sep quote escape ignore fold init streamという呼び出しの場合、

   - sepはセパレータ. デフォルトは","
   - quoteは文字列の括り文字. デフォルトはダブルクォーテーション
   - escapesは文字列中のエスケープ文字. デフォルトはバックスラッシュ
   - ignoreは無視する文字の並び. デフォルトは空白とタブ
   - foldは一行を処理する関数. 任意の値と文字列リストを受け取って任意の値を返す
   - initはfold関数に与える任意の値の初期値
   - streamはパース対象の文字ストリーム

  という意味。戻り値は、foldの最後の戻り値の値.
*)
let parse ?(sep = ',') ?(quote = '"') ?(escapes = "\\") ?(ignore = " \t") fold init = 
  let lf = parser
      [< ''\n'|'\r'; _ = ignores (ignore ^ "\n\r") >] -> ()
  in
  let param = {
    sep = sep;
    quote = quote;
    escapes = escapes;
    ignores = ignore;
  }
  in
  parse_list ~item:(parse_line param) ~sep:lf fold init