8bit.lol
forked from
futur.blue/pegasus
objective categorical abstract machine language personal data server
futur.blue
1open Lexicon_types
2
3(** returns SCCs in reverse topological order (dependencies first)
4 each SCC is a list of nodes *)
5let find_sccs (type node) (nodes : node list) ~(get_id : node -> string)
6 ~(get_deps : node -> string list) : node list list =
7 (* build node map: id -> node *)
8 let node_map =
9 List.fold_left (fun m node -> (get_id node, node) :: m) [] nodes
10 in
11 let node_ids = List.map get_id nodes in
12 (* build dependency map *)
13 let deps = List.map (fun node -> (get_id node, get_deps node)) nodes in
14 (* Tarjan's algorithm state *)
15 let index_counter = ref 0 in
16 let indices = Hashtbl.create 64 in
17 let lowlinks = Hashtbl.create 64 in
18 let on_stack = Hashtbl.create 64 in
19 let stack = ref [] in
20 let sccs = ref [] in
21 let rec strongconnect id =
22 let index = !index_counter in
23 incr index_counter ;
24 Hashtbl.add indices id index ;
25 Hashtbl.add lowlinks id index ;
26 Hashtbl.add on_stack id true ;
27 stack := id :: !stack ;
28 (* visit successors *)
29 let successors =
30 try List.assoc id deps |> List.filter (fun s -> List.mem s node_ids)
31 with Not_found -> []
32 in
33 List.iter
34 (fun succ ->
35 if not (Hashtbl.mem indices succ) then begin
36 (* successor not yet visited *)
37 strongconnect succ ;
38 Hashtbl.replace lowlinks id
39 (min (Hashtbl.find lowlinks id) (Hashtbl.find lowlinks succ))
40 end
41 else if Hashtbl.find_opt on_stack succ = Some true then
42 (* successor is on stack, part of current SCC *)
43 Hashtbl.replace lowlinks id
44 (min (Hashtbl.find lowlinks id) (Hashtbl.find indices succ)) )
45 successors ;
46 (* if this is a root node, pop the SCC *)
47 if Hashtbl.find lowlinks id = Hashtbl.find indices id then begin
48 let rec pop_scc acc =
49 match !stack with
50 | [] ->
51 acc
52 | top :: rest ->
53 stack := rest ;
54 Hashtbl.replace on_stack top false ;
55 if top = id then top :: acc else pop_scc (top :: acc)
56 in
57 let scc_ids = pop_scc [] in
58 (* convert IDs to nodes, preserving original order *)
59 let scc_nodes =
60 List.filter_map
61 (fun n -> List.assoc_opt n node_map)
62 (List.filter (fun n -> List.mem n scc_ids) node_ids)
63 in
64 if scc_nodes <> [] then sccs := scc_nodes :: !sccs
65 end
66 in
67 (* run on all nodes *)
68 List.iter
69 (fun id -> if not (Hashtbl.mem indices id) then strongconnect id)
70 node_ids ;
71 (* SCCs are prepended, so reverse to get topological order *)
72 List.rev !sccs
73
74(** returns list of definition names that this type depends on within the same nsid *)
75let rec collect_local_refs nsid acc = function
76 | Array {items; _} ->
77 collect_local_refs nsid acc items
78 | Ref {ref_; _} ->
79 if String.length ref_ > 0 && ref_.[0] = '#' then
80 (* local ref: #foo *)
81 let def_name = String.sub ref_ 1 (String.length ref_ - 1) in
82 def_name :: acc
83 else begin
84 (* check if it's a self-reference: nsid#foo *)
85 match String.split_on_char '#' ref_ with
86 | [ext_nsid; def_name] when ext_nsid = nsid ->
87 def_name :: acc
88 | _ ->
89 acc
90 end
91 | Union {refs; _} ->
92 List.fold_left
93 (fun a r ->
94 if String.length r > 0 && r.[0] = '#' then
95 let def_name = String.sub r 1 (String.length r - 1) in
96 def_name :: a
97 else
98 match String.split_on_char '#' r with
99 | [ext_nsid; def_name] when ext_nsid = nsid ->
100 def_name :: a
101 | _ ->
102 a )
103 acc refs
104 | Object {properties; _} ->
105 List.fold_left
106 (fun a (_, (prop : property)) -> collect_local_refs nsid a prop.type_def)
107 acc properties
108 | Record {record; _} ->
109 List.fold_left
110 (fun a (_, (prop : property)) -> collect_local_refs nsid a prop.type_def)
111 acc record.properties
112 | Query {parameters; output; _} -> (
113 let acc =
114 match parameters with
115 | Some params ->
116 List.fold_left
117 (fun a (_, (prop : property)) ->
118 collect_local_refs nsid a prop.type_def )
119 acc params.properties
120 | None ->
121 acc
122 in
123 match output with
124 | Some body ->
125 Option.fold ~none:acc ~some:(collect_local_refs nsid acc) body.schema
126 | None ->
127 acc )
128 | Procedure {parameters; input; output; _} -> (
129 let acc =
130 match parameters with
131 | Some params ->
132 List.fold_left
133 (fun a (_, (prop : property)) ->
134 collect_local_refs nsid a prop.type_def )
135 acc params.properties
136 | None ->
137 acc
138 in
139 let acc =
140 match input with
141 | Some body ->
142 Option.fold ~none:acc
143 ~some:(collect_local_refs nsid acc)
144 body.schema
145 | None ->
146 acc
147 in
148 match output with
149 | Some body ->
150 Option.fold ~none:acc ~some:(collect_local_refs nsid acc) body.schema
151 | None ->
152 acc )
153 | _ ->
154 acc
155
156(** find SCCs among definitions within a single lexicon
157 returns SCCs in reverse topological order *)
158let find_def_sccs nsid (defs : def_entry list) : def_entry list list =
159 find_sccs defs
160 ~get_id:(fun def -> def.name)
161 ~get_deps:(fun def -> collect_local_refs nsid [] def.type_def)
162
163(** get external nsid dependencies for a lexicon *)
164let get_external_nsids (doc : lexicon_doc) : string list =
165 let nsids = ref [] in
166 let add_nsid s = if not (List.mem s !nsids) then nsids := s :: !nsids in
167 let rec collect_from_type = function
168 | Array {items; _} ->
169 collect_from_type items
170 | Ref {ref_; _} ->
171 if String.length ref_ > 0 && ref_.[0] <> '#' then begin
172 match String.split_on_char '#' ref_ with
173 | ext_nsid :: _ ->
174 add_nsid ext_nsid
175 | [] ->
176 ()
177 end
178 | Union {refs; _} ->
179 List.iter
180 (fun r ->
181 if String.length r > 0 && r.[0] <> '#' then
182 match String.split_on_char '#' r with
183 | ext_nsid :: _ ->
184 add_nsid ext_nsid
185 | [] ->
186 () )
187 refs
188 | Object {properties; _} ->
189 List.iter
190 (fun (_, (prop : property)) -> collect_from_type prop.type_def)
191 properties
192 | Query {parameters; output; _} ->
193 Option.iter
194 (fun p ->
195 List.iter
196 (fun (_, (prop : property)) -> collect_from_type prop.type_def)
197 p.properties )
198 parameters ;
199 Option.iter (fun o -> Option.iter collect_from_type o.schema) output
200 | Procedure {parameters; input; output; _} ->
201 Option.iter
202 (fun p ->
203 List.iter
204 (fun (_, (prop : property)) -> collect_from_type prop.type_def)
205 p.properties )
206 parameters ;
207 Option.iter (fun i -> Option.iter collect_from_type i.schema) input ;
208 Option.iter (fun o -> Option.iter collect_from_type o.schema) output
209 | Record {record; _} ->
210 List.iter
211 (fun (_, (prop : property)) -> collect_from_type prop.type_def)
212 record.properties
213 | _ ->
214 ()
215 in
216 List.iter (fun def -> collect_from_type def.type_def) doc.defs ;
217 !nsids
218
219(** find SCCs between lexicon files, in reverse topological order *)
220let find_file_sccs (lexicons : lexicon_doc list) : lexicon_doc list list =
221 let nsids = List.map (fun doc -> doc.id) lexicons in
222 find_sccs lexicons
223 ~get_id:(fun doc -> doc.id)
224 ~get_deps:(fun doc ->
225 (* filter to only include nsids we have *)
226 get_external_nsids doc |> List.filter (fun n -> List.mem n nsids) )