%token CR EOF COLON SEMICOLON COMMA OPENP CLOSEP
%token <int> EDGE_LABEL
%token <float> REAL
%token <string> LABEL

%start tree
%type<Newick_bark.newick_bark Gtree.gtree> tree
%%

%{
open Ppatteries

(* parse state *)
type 'a ps = {
  stree: Stree.stree;
  bark: 'a IntMap.t;
}
(* list parse state *)
type 'a lps = {
  stree_l: Stree.stree list;
  bark_l: 'a IntMap.t;
}

let combine = IntMap.fold IntMap.add
let empty_lps = {stree_l = []; bark_l = IntMap.empty}
let lps_append lp lps =
  {stree_l = lp.stree :: lps.stree_l; bark_l = combine lp.bark lps.bark_l}

let node_num = ref (-1)
let add_bark add_fun ?label x s =
  let label =
    match label with
      | None -> Stree.top_id s.stree
      | Some x -> x
  in {
    stree = s.stree;
    bark = add_fun label x s.bark;
  }
let add_bl = add_bark Newick_bark.map_set_bl
let add_name = add_bark Newick_bark.map_set_name
let add_boot = add_bark Newick_bark.map_set_boot
let add_id id lp = {
  stree = Stree.of_id id lp.stree;
  bark =
    try
      let value, bark' = Stree.top_id lp.stree
        |> flip IntMap.extract lp.bark
      in
      IntMap.add id value bark'
    with Not_found -> lp.bark
}

let add_leaf () =
  incr node_num;
  {
    stree = Stree.leaf !node_num;
    bark = IntMap.empty;
  }
let add_internal ls =
  incr node_num;
  {
    stree = Stree.node !node_num ls.stree_l;
    bark = ls.bark_l;
  }

%}

named_leaf:
  | LABEL
      { add_leaf () |> add_name $1 }
  | REAL
      { add_leaf () |> add_name (string_of_float $1) }

subtree_list:
  | subtree COMMA subtree_list
      { lps_append $1 $3 }
  | subtree
      { lps_append $1 empty_lps }

subtree:
  | OPENP subtree_list CLOSEP
      { add_internal $2 }
  | named_leaf { $1 }

tree:
  | subtree EOF
      { Gtree.gtree $1.stree $1.bark }