%token CR EOF COLON SEMICOLON COMMA OPENP CLOSEP %token EDGE_LABEL %token REAL %token LABEL %start tree %type 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: | subtree_list { add_internal $1 } | named_leaf { $1 } tree: | subtree { Gtree.gtree $1.stree $1.bark }