Source file environment.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                                         *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

open UtilsLib
open Signature
open Acg_lexicon

module Environment = struct
  module Env = Utils.StringMap

  type to_be_dumped = bool
  type entry = Signature of Data_Signature.t | Lexicon of Data_Lexicon.t
  type dumped_entry = Signature_d of Data_Signature.t | Lexicon_d of Data_Lexicon.dumped_t

  module Dep = DependencyManager.Make (struct
    type t = string

    let compare e1 e2 = String.compare e1 e2
  end)

  type t = {
    map : (entry * to_be_dumped) Env.t;
    sig_number : int;
    lex_number : int;
    dependencies : Dep.t;
  }

  type dumped_t= {
    dumped_filename : string;
    dumped_map : dumped_entry Env.t;
    dumped_sig_number : int;
    dumped_lex_number : int;
    dumped_dependencies : Dep.t;
  }

  
  let empty =
    {
      map = Env.empty;
      sig_number = 0;
      lex_number = 0;
      dependencies = Dep.empty;
    }

  let update_dependencies lex m =
    match Data_Lexicon.get_dependencies lex with
    | Data_Lexicon.Signatures (s1, s2) ->
        Dep.add_dependency (fst (Data_Lexicon.name lex)) s1
          (Dep.add_dependency (fst (Data_Lexicon.name lex)) s2 m)
    | Data_Lexicon.Lexicons deps ->
      List.fold_left
        (fun acc l -> Dep.add_dependency (fst (Data_Lexicon.name lex)) l acc)
        m
        deps

  let insert ?(overwrite = false) d ~to_be_dumped:dump e =
    match d with
    | Signature s ->
        let name, (p1, p2) = Data_Signature.name s in
        if (not (Env.mem name e.map)) || overwrite then
          {
            e with
            map = Env.add name (d, dump) e.map;
            sig_number = e.sig_number + 1;
          }
        else
          Errors.(EnvironmentErrors.emit (Environment_l.DuplicatedEntry name) ~loc:(p1, p2))
    | Lexicon l ->
        let name, (p1, p2) = Data_Lexicon.name l in
        if (not (Env.mem name e.map)) || overwrite then
          {
            e with
            map = Env.add name (d, dump) e.map;
            lex_number = e.lex_number + 1;
            dependencies = update_dependencies l e.dependencies;
          }
        else
          Errors.(EnvironmentErrors.emit (Environment_l.DuplicatedEntry name) ~loc:(p1, p2))

  let iter f { map = e; _ } = Env.iter (fun _ (d, _) -> f d) e
  let fold f a { map = e; _ } = Env.fold (fun _ (d, _) acc -> f d acc) e a
  let sig_number { sig_number = n; _ } = n
  let lex_number { lex_number = n; _ } = n

  let prepare_dump ?(force=false) ~filename e =
      Env.fold
        (fun name (entry, d) acc ->
           match entry, d || force with
           | _, false -> acc
           | Signature sg, true ->
             {acc with
              dumped_map = Env.add name (Signature_d sg) acc.dumped_map ;
              dumped_sig_number = acc.dumped_sig_number + 1}
           | Lexicon l, true ->
             {acc with
              dumped_map = Env.add name (Lexicon_d (Data_Lexicon.prepare_dump l)) acc.dumped_map ;
              dumped_lex_number = acc.dumped_lex_number + 1})
        e.map
        {dumped_map = Env.empty;
         dumped_filename = filename;
         dumped_sig_number = 0;
         dumped_lex_number = 0;
         dumped_dependencies = e.dependencies}

  let recover_from_dump ~current_env e =
    let get_sig ~lex:lex env name =
      match Env.find_opt name env.map with
      | Some (Signature sg, _) -> sg
      | _ ->
        (match Env.find_opt name current_env.map with
         | Some (Signature sg, _) -> sg
         | _ -> Errors.(LexiconErrors.emit (Lexicon_l.UnavailableSignature (lex, name, e.dumped_filename)))) in
    let new_env, lexicons =
      Env.fold
        (fun name entry (acc, lexs) ->
           match entry with
           | Signature_d sg ->
             {acc with
              map = Env.add name (Signature sg, false) acc.map ;
              sig_number = acc.sig_number + 1},
             lexs
           | Lexicon_d lex ->
             {acc with
              lex_number = acc.lex_number + 1},
             (name, lex)::lexs)
        e.dumped_map
        ({map = Env.empty;
          sig_number = 0;
          lex_number = 0;
          dependencies = e.dumped_dependencies},
         []) in
    List.fold_left
      (fun acc (name, lex) ->
         {acc with    
          map = Env.add name (Lexicon (Data_Lexicon.recover_from_dump ~filename:e.dumped_filename ~get_sig:(get_sig ~lex:(Data_Lexicon.name_of_dumped lex) new_env) lex), false) acc.map})
      new_env
      lexicons
      
  let append ?(overwrite = false) e1 e2 =
    let erased_sig = ref 0 in
    let erased_lex = ref 0 in
    let e2 = recover_from_dump ~current_env:e1 e2 in
    let new_map =
      Env.merge
        (fun _ v1 v2 ->
          match (v1, v2, overwrite) with
          | None, None, _ -> None
          | None, Some v, _ -> Some v
          | Some v, None, _ -> Some v
          | Some (Lexicon _, _), Some v2, true ->
              let () = erased_lex := !erased_lex + 1 in
              Some v2
          | Some (Signature _, _), Some v2, true ->
              let () = erased_sig := !erased_sig + 1 in
              Some v2
          | Some (_, _), Some (v2, _), false -> (
              match v2 with
              | Signature sg ->
                  let name, loc = Data_Signature.name sg in
                  Errors.(EnvironmentErrors.emit (Environment_l.DuplicatedEntry name) ~loc)
              | Lexicon lex ->
                  let name, loc = Data_Lexicon.name lex in
                  Errors.(EnvironmentErrors.emit (Environment_l.DuplicatedEntry name) ~loc)))
        e1.map e2.map
    in
    {
      map = new_map;
      sig_number = e1.sig_number + e2.sig_number - !erased_sig;
      lex_number = e1.lex_number + e2.lex_number - !erased_lex;
      dependencies = Dep.merge e1.dependencies e2.dependencies;
    }

    
  let get entry { map = e; _ } loc =
    try
      let data, _ = Env.find entry e in
      data
    with Not_found -> Errors.(EnvironmentErrors.emit (Environment_l.EntryNotFound entry) ~loc)

  let get_signature s { map = e; _ } loc =
    let data = try
      let data, _ = Env.find s e in
      data
    with Not_found -> Errors.(EnvironmentErrors.emit (Environment_l.EntryNotFound s) ~loc) in
    match data with
    | Signature s -> s
    | _ -> Errors.(EnvironmentErrors.emit (Environment_l.NotASignature s) ~loc)

  let get_lexicon l { map = e; _ } loc =
    let data = try
      let data, _ = Env.find l e in
      data
    with Not_found -> Errors.(EnvironmentErrors.emit (Environment_l.EntryNotFound l) ~loc) in
    match data with
    | Lexicon l -> l
    | _ -> Errors.(EnvironmentErrors.emit (Environment_l.NotALexicon l) ~loc)

  let get_opt s { map = e; _ } =
    try
      let data, _ = Env.find s e in
      Some data
    with Not_found -> None

  let list_signatures { map = e; _ } =
    Seq.fold_left (fun res (name, (entry, _)) -> match entry with | Signature _ -> name :: res | _ -> res) [] (Env.to_seq e)

  let list_lexicons { map = e; _ } =
    Seq.fold_left (fun res (name, (entry, _)) -> match entry with | Lexicon _ -> name :: res | _ -> res) [] (Env.to_seq e)

  let magic e =
    {
      e with
      map =
        Env.map
          (fun v ->
             match v with
             | Signature _, _ -> v
             | Lexicon l, b when (Data_Lexicon.has_magic l) = Data_Lexicon.Available_wo_magic ->
               (Lexicon (Data_Lexicon.magic l), b)
             | Lexicon _, _ -> v)
          e.map;
    }

  exception Sig of Data_Signature.t

  let choose_signature { map = e; _ } =
    try
      let () =
        Env.fold
          (fun _ c a ->
            match c with Signature s, _ -> raise (Sig s) | Lexicon _, _ -> a)
          e ()
      in
      None
    with Sig s -> Some s
end