package frama-c

  1. Overview
  2. Docs
package frama-c
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file requests.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
(**************************************************************************)
(*                                                                        *)
(*  This file is part of Frama-C.                                         *)
(*                                                                        *)
(*  Copyright (C) 2007-2024                                               *)
(*    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 Server

module G = Services.G

(* --- Package declaration --- *)

let package = Package.package ~plugin:"callgraph" ~title:"Callgraph Services" ()


(* --- Helper modules --- *)

module Record () =
struct
  module Record = Data.Record
  type record
  let record : record Record.signature = Record.signature ()
  let field name ?(descr = name) =
    Record.field record ~name ~descr:(Markdown.plain descr)
  let publish ?descr name =
    let descr = Option.map Markdown.plain descr in
    Record.publish record ~package ~name ?descr
end

module Enum (X: sig type t end) =
struct
  module Enum = Data.Enum
  let dictionary: X.t Enum.dictionary = Enum.dictionary ()
  let tag name descr = Enum.tag ~name ~descr:(Markdown.plain descr) dictionary
  let publish lookup name descr =
    Enum.set_lookup dictionary lookup;
    Request.dictionary ~package ~name ~descr:(Markdown.plain descr) dictionary
end


(* --- Types --- *)

module Vertex =
struct
  include Record ()

  let name = field "name" (module Data.Jstring)
      ~descr: "The function name of the node"
  let decl = field "decl" (module Kernel_ast.Decl)
      ~descr: "The declaration tag of the function"
  let is_root = field "is_root" Data.jbool
      ~descr: "whether this node is the root of a service"
  let root = field "root" (module Kernel_ast.Decl)
      ~descr: "the root of this node's service"

  include (val publish "vertex")
  type t = Cil_types.kernel_function Service_graph.vertex

  let to_json (v : Cil_types.kernel_function Service_graph.vertex) =
    default |>
    set name (Kernel_function.get_name v.node) |>
    set decl (Printer_tag.SFunction v.node) |>
    set root (SFunction v.root.node) |>
    set is_root v.is_root |>
    to_json

  let of_json _js = Data.failure "Vertex.of_json not implemented"
end

module EdgeKind =
struct
  include Enum (struct type t = Service_graph.edge end)

  let inter_services =  tag "inter_services" "a call between two services"
  let inter_functions = tag "inter_functions" "a call inside a service"
  let both =            tag "both" "both cases above"

  let lookup = function
    | Service_graph.Inter_services -> inter_services
    | Inter_functions -> inter_functions
    | Both -> both

  include (val publish lookup
              "edgeKind" "Whether the call goes through services or not")
end

module Edge =
struct
  include Record ()

  let src = field "src" (module Kernel_ast.Decl)
  let dst = field "dst" (module Kernel_ast.Decl)
  let kind = field "kind" (module EdgeKind)

  include (val publish "edge")
  type t = G.E.t

  let to_json (e : t) =
    default |>
    set src (SFunction (G.E.src e).node) |>
    set dst (SFunction (G.E.dst e).node) |>
    set kind (G.E.label e) |>
    to_json

  let of_json _js = Data.failure "Edge.of_json not implemented"
end

module Graph =
struct
  include Record ()

  let vertices = field "vertices" (module Data.Jlist (Vertex))
  let edges = field "edges" (module Data.Jlist (Edge))

  include (val publish "graph" ~descr:"The callgraph of the current project")
  type t = G.t

  let get_vertices (g : t) =
    G.fold_vertex (fun v acc -> v :: acc ) g []

  let get_edges (g : t) =
    G.fold_edges_e (fun v acc -> v :: acc ) g []

  let to_json (g : t) =
    default |>
    set vertices (get_vertices g) |>
    set edges (get_edges g) |>
    to_json

  let of_json _js = Data.failure "Graph.of_json not implemented"
end


(* --- Requests --- *)

let _signal =
  States.register_value
    ~package ~name:"callgraph"
    ~descr:(Markdown.plain
              "The current callgraph or an empty graph if it has not been computed yet")
    ~output:(module Data.Joption (Graph))
    ~add_hook:Services.add_hook
    ~get:
      begin fun () ->
        if Services.is_computed () then
          Some (Services.get ())
        else
          None
      end
    ()

let _signal =
  States.register_value
    ~package ~name:"isComputed"
    ~descr:(Markdown.plain
              "This boolean is true if the graph has been computed")
    ~output:(module Data.Jbool)
    ~add_hook:Services.add_hook
    ~get:Services.is_computed
    ()

let () = Request.register ~package
    ~kind:`EXEC ~name:"compute"
    ~descr:(Markdown.plain "Compute the callgraph for the current project")
    ~input:(module Data.Junit) ~output:(module Data.Junit)
    (fun () -> ignore (Services.get ()))
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct