states.ml

(**************************************************************************)
(*                                                                        *)
(*  This file is part of Frama-C.                                         *)
(*                                                                        *)
(*  Copyright (C) 2007-2020                                               *)
(*    CEA (Commissariat à l'énergie atomique et aux énergies              *)
(*         alternatives)                                                  *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, version 2.1.                                              *)
(*                                                                        *)
(*  It is distributed in the hope that it will be useful,                 *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  See the GNU Lesser General Public License version 2.1                 *)
(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
(*                                                                        *)
(**************************************************************************)

open Data

type 'a callback = ('a -> unit) -> unit

let install signal hook = function
  | None -> ()
  | Some add_hook ->
    let once = ref true in
    let install ok =
      if ok && !once then
        begin
          once := false ;
          add_hook hook ;
        end
    in Request.on_signal signal install

let install_emit signal add_hook =
  install signal (fun () -> Request.emit signal) add_hook

(* -------------------------------------------------------------------------- *)
(* --- Values                                                             --- *)
(* -------------------------------------------------------------------------- *)

let register_value (type a) ~package ~name ~descr
    ~(output : a Request.output) ~get
    ?(add_hook : unit callback option) ()
  =
  let open Markdown in
  let href = link ~name () in
  let () = Package.declare
      ~package ~name ~descr D_value in
  let signal = Request.signal
      ~package ~name:(name ^ "Sig")
      ~descr:(plain "Signal for state" @ href) in
  let () = Request.register
      ~package ~name:(name ^ "Get")
      ~descr:(plain "Getter for state" @ href)
      ~kind:`GET ~input:(module Junit) ~output get in
  install_emit signal add_hook ;
  signal

(* -------------------------------------------------------------------------- *)
(* --- States                                                             --- *)
(* -------------------------------------------------------------------------- *)

let register_state (type a) ~package ~name ~descr
    ~(data : a data) ~get ~set
    ?(add_hook : unit callback option) () =
  let open Markdown in
  let module D = (val data) in
  let href = link ~name () in
  let () = Package.declare
      ~package ~name ~descr D_state in
  let signal = Request.signal
      ~package ~name:(name ^ "Sig")
      ~descr:(plain "Signal for state" @ href) in
  let () = Request.register
      ~package ~name:(name ^ "Get")
      ~descr:(plain "Getter for state" @ href)
      ~kind:`GET ~input:(module Junit) ~output:(module D) get in
  let () = Request.register
      ~package ~name:(name ^ "Set")
      ~descr:(plain "Setter for state" @ href)
      ~kind:`SET ~input:(module D) ~output:(module Junit) set in
  install_emit signal add_hook ;
  signal

(* -------------------------------------------------------------------------- *)
(* --- Model Signature                                                    --- *)
(* -------------------------------------------------------------------------- *)

type 'a column = Package.fieldInfo * ('a -> json)

type 'a model = 'a column list ref

let model () = ref []

let column (type a b) ~name ~descr
    ~(data: b Request.output) ~(get : a -> b) (model : a model) =
  let module D = (val data) in
  if name = "key" || name = "index" then
    raise (Invalid_argument "Server.States.column: invalid name") ;
  if List.exists (fun (fd,_) -> fd.Package.fd_name = name) !model then
    raise (Invalid_argument "Server.States.column: duplicate name") ;
  let fd = Package.{
      fd_name = name ;
      fd_type = D.jtype ;
      fd_descr = descr ;
    } in
  model := (fd , fun a -> D.to_json (get a)) :: !model

module Kmap = Map.Make(String)

(* -------------------------------------------------------------------------- *)
(* --- Model Content                                                      --- *)
(* -------------------------------------------------------------------------- *)

type 'a update = Remove | Add of 'a
type 'a content = {
  mutable cleared : bool ;
  mutable updates : 'a update Kmap.t ;
}

type 'a array = {
  signal : Request.signal ;
  key : 'a -> string ;
  iter : ('a -> unit) -> unit ;
  getter : (string * ('a -> json)) list ;
  (* [LC+JS]
     The two following fields allow to keep an array in sync
     with the current project and still have a polymorphic data type. *)
  mutable current : 'a content option ; (* fast access to current project *)
  projects : (string , 'a content) Hashtbl.t ; (* indexed by project *)
}

let synchronize array =
  begin
    Project.register_after_set_current_hook
      ~user_only:false (fun _ -> array.current <- None) ;
    let cleanup p =
      Hashtbl.remove array.projects (Project.get_unique_name p) in
    Project.register_before_remove_hook cleanup ;
    Project.register_todo_before_clear cleanup ;
    Request.on_signal array.signal
      (fun _ ->
         array.current <- None ;
         Hashtbl.clear array.projects ;
      );
  end

let content array =
  match array.current with
  | Some w -> w
  | None ->
    let prj = Project.(current () |> get_unique_name) in
    let content =
      try Hashtbl.find array.projects prj
      with Not_found ->
        let w = {
          cleared = true ;
          updates = Kmap.empty ;
        } in
        Hashtbl.add array.projects prj w ; w
    in
    array.current <- Some content ;
    Request.emit array.signal ;
    content

let reload array =
  let m = content array in
  m.cleared <- true ;
  m.updates <- Kmap.empty ;
  Request.emit array.signal

let update array k =
  let m = content array in
  if not m.cleared then
    begin
      m.updates <- Kmap.add (array.key k) (Add k) m.updates ;
      Request.emit array.signal ;
    end

let remove array k =
  let m = content array in
  if not m.cleared then
    begin
      m.updates <- Kmap.add (array.key k) Remove m.updates ;
      Request.emit array.signal ;
    end

let signal array = array.signal

(* -------------------------------------------------------------------------- *)
(* --- Fetch Model Updates                                                --- *)
(* -------------------------------------------------------------------------- *)

type buffer = {
  reload : bool ;
  mutable capacity : int ;
  mutable pending : int ;
  mutable removed : string list ;
  mutable updated : json list ;
}

let add_entry buffer cols key v =
  let fjs = List.fold_left (fun fjs (fd,to_json) ->
      try (fd , to_json v) :: fjs
      with Not_found -> fjs
    ) [] cols in
  buffer.updated <- `Assoc( ("key", `String key):: fjs) :: buffer.updated ;
  buffer.capacity <- pred buffer.capacity

let remove_entry buffer key =
  buffer.removed <- key :: buffer.removed ;
  buffer.capacity <- pred buffer.capacity

let update_entry buffer cols key = function
  | Remove -> remove_entry buffer key
  | Add v -> add_entry buffer cols key v

let fetch array n =
  let m = content array in
  let reload = m.cleared in
  let buffer = {
    reload ;
    capacity = n ;
    pending = 0 ;
    removed = [] ;
    updated = [] ;
  } in
  begin
    if reload then
      begin
        m.cleared <- false ;
        array.iter
          begin fun v ->
            let key = array.key v in
            if buffer.capacity > 0 then
              add_entry buffer array.getter key v
            else
              ( m.updates <- Kmap.add key (Add v) m.updates ;
                buffer.pending <- succ buffer.pending ) ;
          end ;
      end
    else
      m.updates <- Kmap.filter
          begin fun key upd ->
            if buffer.capacity > 0 then
              ( update_entry buffer array.getter key upd ; false )
            else
              ( buffer.pending <- succ buffer.pending ; true )
          end m.updates ;
  end ;
  buffer

(* -------------------------------------------------------------------------- *)
(* --- Signature Registry                                                 --- *)
(* -------------------------------------------------------------------------- *)

let register_array ~package ~name ~descr ~key
    ~(iter : 'a callback)
    ?(add_update_hook : 'a callback option)
    ?(add_remove_hook : 'a callback option)
    ?(add_reload_hook : unit callback option)
    model =
  let open Markdown in
  let href = link ~name () in
  let columns = List.rev !model in
  let fields = Package.{
      fd_name = "key" ;
      fd_type = Jkey name ;
      fd_descr = plain "Entry identifier." ;
    } :: List.map fst columns in
  let () = Package.declare ~package:package ~name:name ~descr D_array in
  let signal = Request.signal
      ~package ~name:(name ^ "Sig")
      ~descr:(plain "Signal for array" @ href) in
  let row = Package.declare_id
      ~package ~name:(name ^ "Row")
      ~descr:(plain "Data rows for array" @ href)
      (D_record fields) in
  let getter =
    List.map Package.(fun (fd,to_js) -> fd.fd_name , to_js) columns in
  let array = {
    key ; iter ; getter ; signal ;
    current = None ; projects = Hashtbl.create 0
  } in
  let signature = Request.signature () in
  let module Jkeys = Jlist(struct
      include Jstring
      let jtype = Package.Jkey name
    end) in
  let module Jrows = Jlist (struct
      include Jany
      let jtype = Package.Jdata row
    end) in
  let set_reload = Request.result signature
      ~name:"reload" ~descr:(plain "array fully reloaded")
      (module Jbool) in
  let set_removed = Request.result signature
      ~name:"removed" ~descr:(plain "removed entries")
      (module Jkeys) in
  let set_updated = Request.result signature
      ~name:"updated" ~descr:(plain "updated entries")
      (module Jrows) in
  let set_pending = Request.result signature
      ~name:"pending" ~descr:(plain "remaining entries to be fetched")
      (module Jint) in
  Request.register_sig
    ~package ~name:(name ^ "Fetch")
    ~descr:(plain "Data fetcher for array" @ href)
    ~kind:`GET
    signature
    begin fun rq n ->
      let buffer = fetch array n in
      set_reload rq buffer.reload ;
      set_removed rq buffer.removed ;
      set_updated rq buffer.updated ;
      set_pending rq buffer.pending ;
    end ;
  Request.register
    ~package ~name:(name ^ "Reload") ~kind:`GET
    ~descr:(plain "Force full reload for array" @ href)
    ~input:(module Junit) ~output:(module Junit)
    (fun () -> reload array) ;
  synchronize array ;
  install signal (update array) add_update_hook ;
  install signal (remove array) add_remove_hook ;
  install signal (fun () -> reload array) add_reload_hook ;
  array

(* -------------------------------------------------------------------------- *)