Source file tries.ml

(**************************************************************************)
(*                                                                        *)
(*                 ACG development toolkit                                *)
(*                                                                        *)
(*                  Copyright 2008-2023 INRIA                             *)
(*                                                                        *)
(*  More information on "https://acg.loria.fr/"                     *)
(*  License: CeCILL, see the LICENSE file or "http://www.cecill.info"     *)
(*  Authors: see the AUTHORS file                                         *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

module Tries = struct
  (*    type 'a option = None | Some of 'a *)

  type 'a t = ST of 'a option * (char * 'a t) list
  type key = string

  exception Not_found
  exception Conflict

  let empty = ST (None, [])

  let explode str =
    let rec explode_aux i ls =
      if i = -1 then ls else explode_aux (i - 1) (String.get str i :: ls)
    in
    explode_aux (String.length str - 1) []

  let add ?(overwrite = false) id attr smtb =
    let rec insert1 lts (ST (a, s)) =
      match lts with
      | [] -> (
          match (a, overwrite) with
          | None, _ -> ST (Some attr, s)
          | Some _, true -> ST (Some attr, s)
          | Some _, false -> raise Conflict)
      | l :: rm -> ST (a, insert2 l rm s)
    and insert2 lt lts stls =
      match stls with
      | [] -> [ (lt, insert1 lts empty) ]
      | (l, i) :: rm ->
          if lt = l then (lt, insert1 lts i) :: rm
          else if lt <= l then (lt, insert1 lts empty) :: stls
          else (l, i) :: insert2 lt lts rm
    in
    insert1 (explode id) smtb

  let find w smtb =
    let rec lookup1 lts (ST (a, s)) =
      match lts with
      | [] -> ( match a with None -> raise Not_found | Some b -> b)
      | l :: rm -> lookup2 l rm s
    and lookup2 lt lts stls =
      match stls with
      | [] -> raise Not_found
      | (l, i) :: rm ->
          if lt = l then lookup1 lts i
          else if lt <= l then raise Not_found
          else lookup2 lt lts rm
    in
    lookup1 (explode w) smtb

  (* this function is not used neither exposed through the mli file *)
  (*
    let content tr =
      let rec tr_to_list tr ls =
        match tr with
          ST (None, [])          -> ls
        | ST (Some a, [])        -> a::ls
        | ST (None, (_,t)::rm)   -> trls_to_list rm (tr_to_list t ls)
        | ST (Some a, (_,t)::rm) -> trls_to_list rm (tr_to_list t (a::ls))
      and trls_to_list trls ls =
        match trls with
          []         -> ls
        | (_, t)::rm ->  trls_to_list rm (tr_to_list t ls)
      in
      List.rev (tr_to_list tr [])
     *)

  let implode lst =
    let buff = Buffer.create (List.length lst) in
    let () = List.fold_right (fun c _ -> Buffer.add_char buff c) lst () in
    Buffer.contents buff

  let fold f acc tr =
    let rec fold_aux key acc = function
      | ST (None, trs) ->
          List.fold_left (fun acc (c, t) -> fold_aux (c :: key) acc t) acc trs
      | ST (Some v, trs) ->
          let new_acc = f (implode key) v acc in
          List.fold_left
            (fun acc (c, t) -> fold_aux (c :: key) acc t)
            new_acc trs
    in
    fold_aux [] acc tr

  let iter f tr =
    let rec iter_aux key = function
      | ST (None, trs) -> List.iter (fun (c, t) -> iter_aux (c :: key) t) trs
      | ST (v, trs) ->
          let () = match v with None -> () | Some v -> f (implode key) v in
          List.iter (fun (c, t) -> iter_aux (c :: key) t) trs
    in
    iter_aux [] tr

  let pp ?(sep = format_of_string "@,") ppf m tr =
    let l_pp m (k, v) = ppf m k v in
    let first = ref true in
    iter
      (fun k v ->
        if !first then
          let () = first := false in
          ppf m k v
        else Format.fprintf m (sep ^^ "%a") l_pp (k, v))
      tr
end