Skip to content
Snippets Groups Projects
Commit 56c9cbe4 authored by Loïc Correnson's avatar Loïc Correnson
Browse files

[server] removed collections, introduced alist & alpha

parent 463da1dd
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
Showing
with 359 additions and 385 deletions
src/plugins/dive/server_interface.ml
+ 77
− 93
View file @ 56c9cbe4
......@@ -49,104 +49,88 @@ struct
let to_json = fun (g,d) -> Imprecision_graph.diff_to_json g d
end
module Variable = Data.Collection (struct
let name = "variableName"
let descr = Markdown.plain "The name of variable of the program"
let signature = Data.Record.signature ()
let fun_field = Data.Record.option signature
~name:"funName"
~descr:(Markdown.plain "owner function for a local variable")
(module Data.Jstring)
let var_field = Data.Record.field signature
~name:"varName"
~descr:(Markdown.plain "variable name")
(module Data.Jstring)
type t = Cil_types.varinfo
let data = Data.Record.publish ~package ~name ~descr signature
module R = (val data : Data.Record.S with type r = t)
let jtype = R.jtype
let to_json v =
let varname = v.Cil_types.vname in
let fields = R.default |> R.set var_field varname in
let fields = match Kernel_function.find_defining_kf v with
| Some kf -> fields |> R.set fun_field (Some (Kernel_function.get_name kf))
| None -> fields
module Variable =
struct
let name = "variableName"
let descr = Markdown.plain "The name of variable of the program"
let signature = Data.Record.signature ()
let fun_field = Data.Record.option signature
~name:"funName"
~descr:(Markdown.plain "owner function for a local variable")
(module Data.Jstring)
let var_field = Data.Record.field signature
~name:"varName"
~descr:(Markdown.plain "variable name")
(module Data.Jstring)
type t = Cil_types.varinfo
let data = Data.Record.publish ~package ~name ~descr signature
module R = (val data : Data.Record.S with type r = t)
let jtype = R.jtype
let to_json v =
let varname = v.Cil_types.vname in
let fields = R.default |> R.set var_field varname in
let fields = match Kernel_function.find_defining_kf v with
| Some kf -> fields |> R.set fun_field (Some (Kernel_function.get_name kf))
| None -> fields
in
R.to_json fields
let of_json json =
let open Yojson.Basic.Util in
let funname =
try Some (json |> member "fun" |> to_string)
with Not_found -> None
and varname = json |> member "var" |> to_string in
match funname with
| Some name ->
let kf =
try
Globals.Functions.find_by_name name
with Not_found ->
Data.failure "no function '%s'" name
in
let vi =
try Globals.Vars.find_from_astinfo varname (Cil_types.VLocal kf)
with Not_found ->
try Globals.Vars.find_from_astinfo varname (Cil_types.VFormal kf)
with Not_found ->
Data.failure "no variable '%s' in function '%s'"
varname name
in
R.to_json fields
let of_json json =
let open Yojson.Basic.Util in
let funname =
try Some (json |> member "fun" |> to_string)
with Not_found -> None
and varname = json |> member "var" |> to_string in
match funname with
| Some name ->
let kf =
try
Globals.Functions.find_by_name name
with Not_found ->
Data.failure "no function '%s'" name
in
let vi =
try Globals.Vars.find_from_astinfo varname (Cil_types.VLocal kf)
with Not_found ->
try Globals.Vars.find_from_astinfo varname (Cil_types.VFormal kf)
with Not_found ->
Data.failure "no variable '%s' in function '%s'"
varname name
in
vi
vi
| None ->
match
Globals.Syntactic_search.find_in_scope varname Cil_types.Program
with
| Some vi -> vi
| None ->
match
Globals.Syntactic_search.find_in_scope varname Cil_types.Program
with
| Some vi -> vi
| None ->
Data.failure "no global variable '%s'" varname
end)
module Function = Data.Collection (struct
type t = Cil_types.kernel_function
let jtype = Package.Jkey "fct-name"
let to_json kf =
`String (Kernel_function.get_name kf)
let of_json json =
let open Yojson.Basic.Util in
let name = to_string json in
try
Globals.Functions.find_by_name name
with Not_found ->
Data.failure "no function '%s'" name
end)
module Node = Data.Collection (struct
type t = Graph_types.node
Data.failure "no global variable '%s'" varname
end
let jtype = Package.Jindex "dive-node"
module Node : Data.S with type t = Graph_types.node =
struct
type t = Graph_types.node
let to_json node =
`Int node.Graph_types.node_key
let jtype = Package.Jindex "dive-node"
let of_json json =
let open Yojson.Basic.Util in
let node_key = to_int json in
try
Build.find_node (get_graph ()) node_key
with Not_found ->
Data.failure "no node '%d' in the current graph" node_key
end)
let to_json node =
`Int node.Graph_types.node_key
let of_json json =
let open Yojson.Basic.Util in
let node_key = to_int json in
try
Build.find_node (get_graph ()) node_key
with Not_found ->
Data.failure "no node '%d' in the current graph" node_key
end
let () = Request.register ~package
~kind:`GET ~name:"graph"
......@@ -174,7 +158,7 @@ let () = Request.register ~package
let () = Request.register ~package
~kind:`EXEC ~name:"addFunctionAlarms"
~descr:(Markdown.plain "Add all alarms of the given function")
~input:(module Function) ~output:(module GraphDiff)
~input:(module Kernel_ast.Kf) ~output:(module GraphDiff)
begin fun kf ->
let depth = Self.DepthLimit.get () in
let g = get_graph () in
......
src/plugins/dive/server_interface.mli
+ 1
− 1
View file @ 56c9cbe4
......@@ -20,4 +20,4 @@
(* *)
(**************************************************************************)
module Variable : Server.Data.S_collection with type t = Cil_types.varinfo
module Variable : Server.Data.S with type t = Cil_types.varinfo
src/plugins/server/data.ml
+ 111
− 115
View file @ 56c9cbe4
......@@ -108,6 +108,14 @@ end
(* -------------------------------------------------------------------------- *)
module Jlist(A : S) : S with type t = A.t list =
struct
type t = A.t list
let jtype = Jlist A.jtype
let to_json xs = `List (List.map A.to_json xs)
let of_json js = List.map A.of_json (Ju.to_list js)
end
module Jalist(A : S) : S with type t = A.t list =
struct
type t = A.t list
let jtype = Jarray A.jtype
......@@ -127,26 +135,6 @@ struct
let of_json js = Array.of_list @@ List.map A.of_json (Ju.to_list js)
end
(* -------------------------------------------------------------------------- *)
(* --- Collections --- *)
(* -------------------------------------------------------------------------- *)
module type S_collection =
sig
include S
module Joption : S with type t = t option
module Jlist : S with type t = t list
module Jarray : S with type t = t array
end
module Collection(A : S) : S_collection with type t = A.t =
struct
include A
module Joption = Joption(A)
module Jlist = Jlist(A)
module Jarray = Jarray(A)
end
(* -------------------------------------------------------------------------- *)
(* --- Atomic Types --- *)
(* -------------------------------------------------------------------------- *)
......@@ -167,52 +155,55 @@ struct
let to_json js = js
end
module Jbool : S_collection with type t = bool =
Collection
(struct
type t = bool
let jtype = Jboolean
let of_json = Ju.to_bool
let to_json b = `Bool b
end)
module Jbool : S with type t = bool =
struct
type t = bool
let jtype = Jboolean
let of_json = Ju.to_bool
let to_json b = `Bool b
end
module Jint : S_collection with type t = int =
Collection
(struct
type t = int
let jtype = Jnumber
let of_json = Ju.to_int
let to_json n = `Int n
end)
module Jint : S with type t = int =
struct
type t = int
let jtype = Jnumber
let of_json = Ju.to_int
let to_json n = `Int n
end
module Jfloat : S_collection with type t = float =
Collection
(struct
type t = float
let jtype = Jnumber
let of_json = Ju.to_number
let to_json v = `Float v
end)
module Jfloat : S with type t = float =
struct
type t = float
let jtype = Jnumber
let of_json = Ju.to_number
let to_json v = `Float v
end
module Jstring : S_collection with type t = string =
Collection
(struct
type t = string
let jtype = Jstring
let of_json = Ju.to_string
let to_json s = `String s
end)
module Jstring : S with type t = string =
struct
type t = string
let jtype = Jstring
let of_json = Ju.to_string
let to_json s = `String s
end
module Jmarkdown : S_collection with type t = Markdown.text =
Collection
(struct
type t = Markdown.text
let jtype =
let descr = Markdown.plain "Markdown (inlined) text." in
datatype ~package ~name:"markdown" ~descr Jstring
let of_json js = Markdown.plain (Ju.to_string js)
let to_json txt = `String (Pretty_utils.to_string Markdown.pp_text txt)
end)
module Jalpha : S with type t = string =
struct
type t = string
let jtype = Jalpha
let of_json = Ju.to_string
let to_json s = `String s
end
module Jmarkdown : S with type t = Markdown.text =
struct
type t = Markdown.text
let jtype =
let descr = Markdown.plain "Markdown (inlined) text." in
datatype ~package ~name:"markdown" ~descr Jstring
let of_json js = Markdown.plain (Ju.to_string js)
let to_json txt = `String (Pretty_utils.to_string Markdown.pp_text txt)
end
module Jtext =
struct
......@@ -238,6 +229,7 @@ let jbool : bool data = (module Jbool)
let jint : int data = (module Jint)
let jfloat : float data = (module Jfloat)
let jstring : string data = (module Jstring)
let jalpha : string data = (module Jalpha)
let jkey ~kind =
let module JkeyKind =
......@@ -263,6 +255,10 @@ let jlist (type a) (d : a data) : a list data =
let module A = Jlist(val d) in
(module A : S with type t = a list)
let jalist (type a) (d : a data) : a list data =
let module A = Jalist(val d) in
(module A : S with type t = a list)
let jarray (type a) (d : a data) : a array data =
let module A = Jarray(val d) in
(module A : S with type t = a array)
......@@ -380,32 +376,32 @@ end
(* --- Enums --- *)
(* -------------------------------------------------------------------------- *)
module Tag = Collection
(struct
type t = Package.tagInfo
module Tag =
struct
type t = Package.tagInfo
let jtype =
datatype ~package ~name:"tag"
~descr:(Markdown.plain "Enum Tag Description")
(Jrecord [
"name",Jstring ;
"label",Jmarkdown.jtype ;
"descr",Jmarkdown.jtype ;
])
let to_json tg = `Assoc Package.[
"name", `String tg.tg_name ;
"label", Jmarkdown.to_json tg.tg_label ;
"descr" , Jmarkdown.to_json tg.tg_descr ;
]
let of_json js = Package.{
tg_name = Ju.member "name" js |> Ju.to_string ;
tg_label = Ju.member "label" js |> Jmarkdown.of_json ;
tg_descr = Ju.member "descr" js |> Jmarkdown.of_json ;
}
let jtype =
datatype ~package ~name:"tag"
~descr:(Markdown.plain "Enum Tag Description")
(Jrecord [
"name",Jstring ;
"label",Jmarkdown.jtype ;
"descr",Jmarkdown.jtype ;
])
let to_json tg = `Assoc Package.[
"name", `String tg.tg_name ;
"label", Jmarkdown.to_json tg.tg_label ;
"descr" , Jmarkdown.to_json tg.tg_descr ;
]
let of_json js = Package.{
tg_name = Ju.member "name" js |> Ju.to_string ;
tg_label = Ju.member "label" js |> Jmarkdown.of_json ;
tg_descr = Ju.member "descr" js |> Jmarkdown.of_json ;
}
end)
end
module Enum =
struct
......@@ -551,14 +547,14 @@ end
module type Index =
sig
type t
include S
val kind : string
val get : t -> int
val find : int -> t
val clear : unit -> unit
end
module INDEXER(M : Map)(D : S_collection)(I : Index with type t = D.t) :
module INDEXER(M : Map)(D : S)(I : Index with type t = D.t) :
sig
type index
val create : unit -> index
......@@ -608,7 +604,7 @@ struct
end
module Static(M : Map)(S : S_collection)(I : Index with type t = S.t)
module Static(M : Map)(S : S)(I : Index with type t = S.t)
: Index with type t = M.key =
struct
module INDEX = INDEXER(M)(S)(I)
......@@ -617,16 +613,16 @@ struct
let clear () = INDEX.clear index
let get = INDEX.get index
let find = INDEX.find index
include Collection
(struct
type t = M.key
let jtype = Jindex I.kind
let of_json = INDEX.of_json index
let to_json = INDEX.to_json index
end)
include
(struct
type t = M.key
let jtype = Jindex I.kind
let of_json = INDEX.of_json index
let to_json = INDEX.to_json index
end)
end
module Index(M : Map)(S : S_collection)(I : Index with type t = S.t)
module Index(M : Map)(S : S)(I : Index with type t = S.t)
: Index with type t = M.key =
struct
module INDEX = INDEXER(M)(S)(I)
......@@ -653,13 +649,13 @@ struct
let get a = INDEX.get (index()) a
let find id = INDEX.find (index()) id
include Collection
(struct
type t = M.key
let jtype = Jindex I.kind
let of_json js = INDEX.of_json (index()) js
let to_json v = INDEX.to_json (index()) v
end)
include
(struct
type t = M.key
let jtype = Jindex I.kind
let of_json js = INDEX.of_json (index()) js
let to_json v = INDEX.to_json (index()) v
end)
end
......@@ -669,7 +665,7 @@ sig
val id : t -> int
end
module Identified(A : IdentifiedType)(S : S_collection)
module Identified(A : IdentifiedType)(S : S)
(I : Index with type t = S.t) : Index with type t = A.t =
struct
......@@ -700,16 +696,16 @@ struct
let get = A.id
let find id = Hashtbl.find (lookup()) id
include Collection
(struct
type t = A.t
let jtype = Jindex kind
let to_json a = `Int (get a)
let of_json js =
let k = Ju.to_int js in
try find k
with Not_found -> failure "[%s] No registered id #%d" I.kind k
end)
include
(struct
type t = A.t
let jtype = Jindex kind
let to_json a = `Int (get a)
let of_json js =
let k = Ju.to_int js in
try find k
with Not_found -> failure "[%s] No registered id #%d" I.kind k
end)
end
......
src/plugins/server/data.mli
+ 12
− 24
View file @ 56c9cbe4
......@@ -70,30 +70,16 @@ sig
val to_json : t -> json
end
(* -------------------------------------------------------------------------- *)
(** {2 Collections} *)
(* -------------------------------------------------------------------------- *)
module type S_collection =
sig
include S
module Joption : S with type t = t option
module Jlist : S with type t = t list
module Jarray : S with type t = t array
end
module Collection(A : S) : S_collection with type t = A.t
(* -------------------------------------------------------------------------- *)
(** {2 Atomic Data} *)
(* -------------------------------------------------------------------------- *)
module Junit : S with type t = unit
module Jany : S with type t = json
module Jbool : S_collection with type t = bool
module Jint : S_collection with type t = int
module Jfloat : S_collection with type t = float
module Jstring : S_collection with type t = string
module Jbool : S with type t = bool
module Jint : S with type t = int
module Jfloat : S with type t = float
module Jstring : S with type t = string
module Jtext : S with type t = json (** Rich text encoding, see [Jbuffer]. *)
module Jmarkdown : S with type t = Markdown.text
......@@ -105,6 +91,7 @@ module Joption(A : S) : S with type t = A.t option
module Jpair(A : S)(B : S) : S with type t = A.t * B.t
module Jtriple(A : S)(B : S)(C : S) : S with type t = A.t * B.t * C.t
module Jlist(A : S) : S with type t = A.t list
module Jalist(A : S) : S with type t = A.t list
module Jarray(A : S) : S with type t = A.t array
(* -------------------------------------------------------------------------- *)
......@@ -120,9 +107,11 @@ val jbool : bool data
val jint : int data
val jfloat : float data
val jstring : string data
val jalpha : string data
val jindex : kind:string -> int data
val jkey : kind:string -> string data
val jlist : 'a data -> 'a list data
val jalist : 'a data -> 'a list data
val jarray : 'a data -> 'a array data
val joption : 'a data -> 'a option data
......@@ -196,7 +185,7 @@ end
(** {2 Enums} *)
(* -------------------------------------------------------------------------- *)
module Tag : S_collection with type t = tagInfo
module Tag : S with type t = tagInfo
(** Enum factory.
......@@ -329,7 +318,7 @@ end
(** Datatype extended with access to value identifiers. *)
module type Index =
sig
type t
include S
val kind : string
val get : t -> int
val find : int -> t (** @raise Not_found if not registered. *)
......@@ -338,11 +327,11 @@ sig
end
(** Builds an indexer that {i does not} depend on current project. *)
module Static(M : Map)(S : S_collection)
module Static(M : Map)(S : S)
(I : Index with type t = S.t) : Index with type t = M.key
(** Builds a {i projectified} index. *)
module Index(M : Map)(S : S_collection)
module Index(M : Map)(S : S)
(I : Index with type t = S.t) : Index with type t = M.key
(** Datatype already identified by unique integers. *)
......@@ -353,8 +342,7 @@ sig
end
(** Builds a {i projectified} index on types with {i unique} identifiers. *)
module Identified(A : IdentifiedType)
(S : S_collection)
module Identified(A : IdentifiedType)(S : S)
(I : Index with type t = S.t) : Index with type t = A.t
(* -------------------------------------------------------------------------- *)
......
src/plugins/server/kernel_ast.ml
+ 40
− 40
View file @ 56c9cbe4
......@@ -202,43 +202,43 @@ module Printer = Printer_tag.Make(Marker)
(* --- Ast Data --- *)
(* -------------------------------------------------------------------------- *)
module Stmt = Data.Collection
(struct
type t = stmt
let jtype = Marker.jstmt
let to_json st =
let kf = Kernel_function.find_englobing_kf st in
Marker.to_json (PStmt(kf,st))
let of_json js =
let open Printer_tag in
match Marker.of_json js with
| PStmt(_,st) | PStmtStart(_,st) -> st
| _ -> Data.failure "not a stmt marker"
end)
module Ki = Data.Collection
(struct
type t = kinstr
let jtype = Pkg.Joption Marker.jstmt
let to_json = function
| Kglobal -> `Null
| Kstmt st -> Stmt.to_json st
let of_json = function
| `Null -> Kglobal
| js -> Kstmt (Stmt.of_json js)
end)
module Kf = Data.Collection
(struct
type t = kernel_function
let jtype = Pkg.Jkey "fct"
let to_json kf =
`String (Kernel_function.get_name kf)
let of_json js =
let key = Js.to_string js in
try Globals.Functions.find_by_name key
with Not_found -> Data.failure "Undefined function '%s'" key
end)
module Stmt =
struct
type t = stmt
let jtype = Marker.jstmt
let to_json st =
let kf = Kernel_function.find_englobing_kf st in
Marker.to_json (PStmt(kf,st))
let of_json js =
let open Printer_tag in
match Marker.of_json js with
| PStmt(_,st) | PStmtStart(_,st) -> st
| _ -> Data.failure "not a stmt marker"
end
module Ki =
struct
type t = kinstr
let jtype = Pkg.Joption Marker.jstmt
let to_json = function
| Kglobal -> `Null
| Kstmt st -> Stmt.to_json st
let of_json = function
| `Null -> Kglobal
| js -> Kstmt (Stmt.of_json js)
end
module Kf =
struct
type t = kernel_function
let jtype = Pkg.Jkey "fct"
let to_json kf =
`String (Kernel_function.get_name kf)
let of_json js =
let key = Js.to_string js in
try Globals.Functions.find_by_name key
with Not_found -> Data.failure "Undefined function '%s'" key
end
(* -------------------------------------------------------------------------- *)
(* --- Functions --- *)
......@@ -247,7 +247,7 @@ module Kf = Data.Collection
let () = Request.register ~package
~kind:`GET ~name:"getFunctions"
~descr:(Md.plain "Collect all functions in the AST")
~input:(module Junit) ~output:(module Kf.Jlist)
~input:(module Junit) ~output:(module Jlist(Kf))
begin fun () ->
let pool = ref [] in
Globals.Functions.iter (fun kf -> pool := kf :: !pool) ;
......@@ -376,7 +376,7 @@ let () =
~descr:(Md.plain "Get the currently analyzed source file names")
~kind:`GET
~name:"getFiles"
~input:(module Junit) ~output:(module Jstring.Jlist)
~input:(module Junit) ~output:(module Jlist(Jstring))
get_files
let set_files files =
......@@ -389,7 +389,7 @@ let () =
~descr:(Md.plain "Set the source file names to analyze.")
~kind:`SET
~name:"setFiles"
~input:(module Jstring.Jlist)
~input:(module Jlist(Jstring))
~output:(module Junit)
set_files
......
src/plugins/server/kernel_ast.mli
+ 3
− 3
View file @ 56c9cbe4
......@@ -27,9 +27,9 @@
open Package
open Cil_types
module Kf : Data.S_collection with type t = kernel_function
module Ki : Data.S_collection with type t = kinstr
module Stmt : Data.S_collection with type t = stmt
module Kf : Data.S with type t = kernel_function
module Ki : Data.S with type t = kinstr
module Stmt : Data.S with type t = stmt
module Marker :
sig
......
src/plugins/server/kernel_main.ml
+ 86
− 85
View file @ 56c9cbe4
......@@ -44,8 +44,9 @@ let () =
let set_datadir = result "datadir" "Shared directory (FRAMAC_SHARE)" in
let set_libdir = result "libdir" "Lib directory (FRAMAC_LIB)" in
let set_pluginpath = Request.result signature
~name:"pluginpath" ~descr:(Md.plain "Plugin directories (FRAMAC_PLUGIN)")
(module Jstring.Jlist) in
~name:"pluginpath"
~descr:(Md.plain "Plugin directories (FRAMAC_PLUGIN)")
(module Jlist(Jstring)) in
Request.register_sig
~package ~kind:`GET ~name:"getConfig"
~descr:(Md.plain "Frama-C Kernel configuration")
......@@ -65,7 +66,7 @@ let () =
Request.register ~package ~kind:`SET ~name:"load"
~descr:(Md.plain "Load a save file. Returns an error, if not successfull.")
~input:(module Jstring)
~output:(module Jstring.Joption)
~output:(module Joption(Jstring))
(fun file ->
try Project.load_all (Filepath.Normalized.of_string file); None
with Project.IOError err -> Some err)
......@@ -74,42 +75,42 @@ let () =
(* --- File Positions --- *)
(* -------------------------------------------------------------------------- *)
module LogSource = Collection
(struct
type t = Filepath.position
let jtype = Pkg.datatype ~package ~name:"source"
~descr:(Md.plain "Source file positions.")
(Jrecord [
"dir", Jstring;
"base", Jstring;
"file", Jstring;
"line", Jnumber;
])
let to_json p =
let path = Filepath.(Normalized.to_pretty_string p.pos_path) in
`Assoc [
"dir" , `String (Filename.dirname path) ;
"base" , `String (Filename.basename path) ;
"file" , `String (p.Filepath.pos_path :> string) ;
"line" , `Int p.Filepath.pos_lnum ;
]
let of_json js =
let fail () = failure_from_type_error "Invalid source format" js in
match js with
| `Assoc assoc ->
begin
match List.assoc "file" assoc, List.assoc "line" assoc with
| `String path, `Int line ->
Log.source ~file:(Filepath.Normalized.of_string path) ~line
| _, _ -> fail ()
| exception Not_found -> fail ()
end
| _ -> fail ()
end)
module LogSource =
struct
type t = Filepath.position
let jtype = Pkg.datatype ~package ~name:"source"
~descr:(Md.plain "Source file positions.")
(Jrecord [
"dir", Jstring;
"base", Jstring;
"file", Jstring;
"line", Jnumber;
])
let to_json p =
let path = Filepath.(Normalized.to_pretty_string p.pos_path) in
`Assoc [
"dir" , `String (Filename.dirname path) ;
"base" , `String (Filename.basename path) ;
"file" , `String (p.Filepath.pos_path :> string) ;
"line" , `Int p.Filepath.pos_lnum ;
]
let of_json js =
let fail () = failure_from_type_error "Invalid source format" js in
match js with
| `Assoc assoc ->
begin
match List.assoc "file" assoc, List.assoc "line" assoc with
| `String path, `Int line ->
Log.source ~file:(Filepath.Normalized.of_string path) ~line
| _, _ -> fail ()
| exception Not_found -> fail ()
end
| _ -> fail ()
end
(* -------------------------------------------------------------------------- *)
(* --- Log Lind --- *)
......@@ -151,53 +152,53 @@ end
(* --- Log Events --- *)
(* -------------------------------------------------------------------------- *)
module LogEvent = Collection
(struct
type rlog
let jlog : rlog Record.signature = Record.signature ()
let kind = Record.field jlog ~name:"kind"
~descr:(Md.plain "Message kind") (module LogKind)
let plugin = Record.field jlog ~name:"plugin"
~descr:(Md.plain "Emitter plugin") (module Jstring)
let message = Record.field jlog ~name:"message"
~descr:(Md.plain "Message text") (module Jstring)
let category = Record.option jlog ~name:"category"
~descr:(Md.plain "Message category (DEBUG or WARNING)") (module Jstring)
let source = Record.option jlog ~name:"source"
~descr:(Md.plain "Source file position") (module LogSource)
let data = Record.publish ~package ~name:"log"
~descr:(Md.plain "Message event record.") jlog
module R : Record.S with type r = rlog = (val data)
type t = Log.event
let jtype = R.jtype
let to_json evt =
R.default |>
R.set plugin evt.Log.evt_plugin |>
R.set kind evt.Log.evt_kind |>
R.set category evt.Log.evt_category |>
R.set source evt.Log.evt_source |>
R.set message evt.Log.evt_message |>
R.to_json
module LogEvent =
struct
let of_json js =
let r = R.of_json js in
{
Log.evt_plugin = R.get plugin r ;
Log.evt_kind = R.get kind r ;
Log.evt_category = R.get category r ;
Log.evt_source = R.get source r ;
Log.evt_message = R.get message r ;
}
type rlog
let jlog : rlog Record.signature = Record.signature ()
let kind = Record.field jlog ~name:"kind"
~descr:(Md.plain "Message kind") (module LogKind)
let plugin = Record.field jlog ~name:"plugin"
~descr:(Md.plain "Emitter plugin") (module Jstring)
let message = Record.field jlog ~name:"message"
~descr:(Md.plain "Message text") (module Jstring)
let category = Record.option jlog ~name:"category"
~descr:(Md.plain "Message category (DEBUG or WARNING)") (module Jstring)
let source = Record.option jlog ~name:"source"
~descr:(Md.plain "Source file position") (module LogSource)
let data = Record.publish ~package ~name:"log"
~descr:(Md.plain "Message event record.") jlog
module R : Record.S with type r = rlog = (val data)
type t = Log.event
let jtype = R.jtype
let to_json evt =
R.default |>
R.set plugin evt.Log.evt_plugin |>
R.set kind evt.Log.evt_kind |>
R.set category evt.Log.evt_category |>
R.set source evt.Log.evt_source |>
R.set message evt.Log.evt_message |>
R.to_json
let of_json js =
let r = R.of_json js in
{
Log.evt_plugin = R.get plugin r ;
Log.evt_kind = R.get kind r ;
Log.evt_category = R.get category r ;
Log.evt_source = R.get source r ;
Log.evt_message = R.get message r ;
}
end)
end
(* -------------------------------------------------------------------------- *)
(* --- Log Monitoring --- *)
......@@ -245,7 +246,7 @@ let () = Request.register
let () = Request.register
~package ~kind:`GET ~name:"getLogs"
~descr:(Md.plain "Flush the last emitted logs since last call (max 100)")
~input:(module Junit) ~output:(module LogEvent.Jlist)
~input:(module Junit) ~output:(module Jlist(LogEvent))
begin fun () ->
let pool = ref [] in
let count = ref 100 in
......
src/plugins/server/kernel_main.mli
+ 2
− 2
View file @ 56c9cbe4
......@@ -24,7 +24,7 @@
(** Kernel Services *)
(* -------------------------------------------------------------------------- *)
module LogSource : Data.S_collection with type t = Filepath.position
module LogEvent : Data.S_collection with type t = Log.event
module LogSource : Data.S with type t = Filepath.position
module LogEvent : Data.S with type t = Log.event
(* -------------------------------------------------------------------------- *)
src/plugins/server/kernel_properties.ml
+ 5
− 5
View file @ 56c9cbe4
......@@ -273,7 +273,7 @@ let () = States.column model ~name:"kind"
let () = States.column model ~name:"names"
~descr:(Md.plain "Names")
~data:(module Jstring.Jlist)
~data:(module Jlist(Jstring))
~get:Property.get_names
let () = States.column model ~name:"status"
......@@ -283,7 +283,7 @@ let () = States.column model ~name:"status"
let () = States.column model ~name:"function"
~descr:(Md.plain "Function")
~data:(module Kf.Joption) ~get:Property.get_kf
~data:(module Joption(Kf)) ~get:Property.get_kf
let () = States.column model ~name:"kinstr"
~descr:(Md.plain "Instruction")
......@@ -296,17 +296,17 @@ let () = States.column model ~name:"source"
let () = States.column model ~name:"alarm"
~descr:(Md.plain "Alarm name (if the property is an alarm)")
~data:(module Jstring.Joption)
~data:(module Joption(Jstring))
~get:(fun ip -> Extlib.opt_map Alarms.get_short_name (find_alarm ip))
let () = States.column model ~name:"alarm_descr"
~descr:(Md.plain "Alarm description (if the property is an alarm)")
~data:(module Jstring.Joption)
~data:(module Joption(Jstring))
~get:(fun ip -> Extlib.opt_map Alarms.get_description (find_alarm ip))
let () = States.column model ~name:"predicate"
~descr:(Md.plain "Predicate")
~data:(module Jstring.Joption)
~data:(module Joption(Jstring))
~get:(fun ip -> Extlib.opt_map snd (Description.property_kind_and_node ip))
let is_relevant ip =
......
src/plugins/server/package.ml
+ 8
− 6
View file @ 56c9cbe4
......@@ -165,12 +165,14 @@ type jtype =
| Jboolean
| Jnumber
| Jstring
| Jalpha (* string primarily compared without case *)
| Jtag of string
| Jkey of string (* kind of a string used for indexing *)
| Jindex of string (* kind of a number used for indexing *)
| Jindex of string (* kind of an integer used for indexing *)
| Joption of jtype
| Jassoc of string * jtype (* kind of keys *)
| Jarray of jtype
| Jlist of jtype (* order does not matter *)
| Jarray of jtype (* order matters *)
| Jtuple of jtype list
| Junion of jtype list
| Jrecord of (string * jtype) list
......@@ -251,8 +253,8 @@ let pp_pkgname fmt { p_plugin ; p_package } =
let rec visit_jtype fn = function
| Jany | Jself | Jnull | Jboolean | Jnumber
| Jstring | Jindex _ | Jkey _ | Jtag _ -> ()
| Joption js | Jassoc(_,js) | Jarray js -> visit_jtype fn js
| Jstring | Jalpha | Jkey _ | Jindex _ | Jtag _ -> ()
| Joption js | Jassoc(_,js) | Jarray js | Jlist js -> visit_jtype fn js
| Jtuple js | Junion js -> List.iter (visit_jtype fn) js
| Jrecord fjs -> List.iter (fun (_,js) -> visit_jtype fn js) fjs
| Jdata id -> fn id
......@@ -409,7 +411,7 @@ let rec md_jtype pp = function
| Jnull -> Md.emph "null"
| Jnumber -> Md.emph "number"
| Jboolean -> Md.emph "boolean"
| Jstring -> Md.emph "string"
| Jstring | Jalpha -> Md.emph "string"
| Jtag tag -> escaped tag
| Jkey kd -> key kd
| Jindex kd -> index kd
......@@ -417,7 +419,7 @@ let rec md_jtype pp = function
| Joption js -> protect pp js @ Md.code "?"
| Jtuple js -> Md.code "[" @ md_jlist pp "," js @ Md.code "]"
| Junion js -> md_jlist pp "|" js
| Jarray js -> protect pp js @ Md.code "[]"
| Jarray js | Jlist js -> protect pp js @ Md.code "[]"
| Jrecord fjs -> Md.code "{" @ fields pp fjs @ Md.code "}"
| Jassoc (id,js) ->
Md.code "{[" @ key id @ Md.code "]:" @ md_jtype pp js @ Md.code "}"
......
src/plugins/server/package.mli
+ 8
− 6
View file @ 56c9cbe4
......@@ -33,12 +33,14 @@ type jtype =
| Jboolean
| Jnumber
| Jstring
| Jtag of string (** Enum constant tag *)
| Jkey of string (** Kind of numbers used for indexing *)
| Jindex of string (** Kind of strings used for indexing *)
| Joption of jtype (** Value or 'null' *)
| Jassoc of string * jtype (** Dictionary for kind of ids *)
| Jarray of jtype
| Jalpha (** string primarily compared without case *)
| Jtag of string
| Jkey of string (** kind of a string used for indexing *)
| Jindex of string (** kind of an integer used for indexing *)
| Joption of jtype
| Jassoc of string * jtype (** kind of keys *)
| Jlist of jtype (** order does not matter *)
| Jarray of jtype (** order matters *)
| Jtuple of jtype list
| Junion of jtype list
| Jrecord of (string * jtype) list
......
src/plugins/server/request.ml
+ 6
− 5
View file @ 56c9cbe4
......@@ -291,15 +291,16 @@ let register ~package ~kind ~name ~descr ~input ~output process =
(fun _rq v -> process v)
let dictionary (type a) ~package ~name ~descr (d : a Data.Enum.dictionary) =
let data = Data.Enum.publish ~package ~name ~descr d in
let open Data in
let data = Enum.publish ~package ~name ~descr d in
let module T = (val data) in
let descr = Markdown.plain "Returns all registered tags for the above type." in
let descr = Markdown.plain "Registered tags for the above type." in
let name = name ^ "Tags" in
register ~kind:`GET ~package
~name ~descr
~input:(module Data.Junit)
~output:(module Data.Tag.Jlist)
(fun () -> Data.Enum.tags d) ;
~input:(module Junit)
~output:(module Jlist(Tag))
(fun () -> Enum.tags d) ;
data
(* -------------------------------------------------------------------------- *)
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment