From fd4e46653d94807a52d5506a172791f1ec1ec891 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Tue, 21 Jul 2026 02:18:27 -0300 Subject: architecture diagram on CI --- .github/workflows/uml.yml | 59 +++++++++ docs/architecture.puml | 246 ++++++++++++++++++++++++++++++++++ lib/abstract/Storage.ml | 5 + lib/backend/execution/FOL.ml | 5 + lib/backend/managers/Cursor.ml | 6 + lib/backend/managers/Handle.ml | 8 ++ lib/backend/managers/Identity.ml | 2 + lib/backend/managers/Lifecycle.ml | 4 + lib/backend/managers/Namespace.ml | 5 + lib/backend/managers/Object.ml | 4 + lib/backend/storage/LMDB.ml | 7 + lib/concepts/Condition.ml | 2 + lib/concepts/Configuration.ml | 2 + lib/concepts/Hash.ml | 2 + lib/concepts/Representation.ml | 2 + lib/concepts/Tuple.ml | 2 + rnt.opam | 1 - tools/uml_blueprint.pl | 271 ++++++++++++++++++++++++++++++++++++++ 18 files changed, 632 insertions(+), 1 deletion(-) create mode 100644 .github/workflows/uml.yml create mode 100644 docs/architecture.puml create mode 100644 tools/uml_blueprint.pl diff --git a/.github/workflows/uml.yml b/.github/workflows/uml.yml new file mode 100644 index 0000000..8850083 --- /dev/null +++ b/.github/workflows/uml.yml @@ -0,0 +1,59 @@ +name: UML + +on: + pull_request: + workflow_dispatch: + +permissions: + contents: write + +jobs: + blueprint: + runs-on: ubuntu-latest + steps: + - name: Checkout PR branch + uses: actions/checkout@v4 + with: + # Check out the PR's source branch (not the detached merge commit) so + # the regenerated diagram can be pushed straight back to it. + ref: ${{ github.head_ref }} + + - name: Install Nix + uses: cachix/install-nix-action@v27 + + - name: Generate PlantUML blueprint + # --strict fails the job if a @uses/@needs tag names an unknown module. + run: | + nix shell nixpkgs#perl --command \ + perl tools/uml_blueprint.pl --src lib --out docs/architecture.puml --strict --no-notes + + - name: Render diagram + run: | + nix shell nixpkgs#plantuml --command \ + plantuml -tsvg docs/architecture.puml + + - name: Upload blueprint artifact + uses: actions/upload-artifact@v4 + with: + name: architecture-diagram + path: | + docs/architecture.puml + docs/architecture.svg + + - name: Commit updated diagram to the PR branch + # Only same-repo PRs can be pushed to; fork PRs get the artifact instead. + if: >- + github.event_name == 'pull_request' && + github.event.pull_request.head.repo.full_name == github.repository + run: | + git config user.name "github-actions[bot]" + git config user.email "41898282+github-actions[bot]@users.noreply.github.com" + git add docs/architecture.puml docs/architecture.svg + if git diff --cached --quiet; then + echo "diagram unchanged — nothing to commit" + else + # [skip ci] stops this auto-commit from retriggering the workflow; + # the diff guard above stops it once the diagram stabilises. + git commit -m "ci: update architecture diagram [skip ci]" + git push origin HEAD:${{ github.head_ref }} + fi diff --git a/docs/architecture.puml b/docs/architecture.puml new file mode 100644 index 0000000..87b462b --- /dev/null +++ b/docs/architecture.puml @@ -0,0 +1,246 @@ +@startuml +!theme toy +title RNT Architecture +hide empty members +skinparam classAttributeIconSize 0 +skinparam linetype ortho +skinparam nodesep 30 +skinparam ranksep 50 +skinparam defaultFontSize 15 +left to right direction + +class Condition <> { + .. types .. + +condition + +ps + .. values .. + +"|=|" + +"&" + +empty() : ps + +condition() : condition + +complement() : condition + +to_string_hum() : string +} + +class Configuration <> { + .. types .. + +term + +dictionary + .. values .. + +term_of_sexp() : term + +tag_of() : string, Condition.condition result + +value_for() : term, Condition.condition result + +as_dictionary() : dictionary, Condition.condition result + +as_int() : int, Condition.condition result + +as_string() : string, Condition.condition result +} + +class Cursor <> { + .. types .. + +descriptor + +cursor + .. values .. + +open_() : cursor, Concepts.Condition.condition result + +next() : Concepts.Tuple.t option, Concepts.Condition.condition result + +close() : unit +} + +class FOL <> { + .. types .. + +path_arg + +t + +stream + +right + .. values .. + +singleton() + +resolve() +} + +class Handle <> { + .. types .. + +t + +handle + +cursor + .. values .. + +open_() : handle, Concepts.Condition.condition result + +open_cursor() : cursor, Concepts.Condition.condition result + +next() : Concepts.Tuple.t option, Concepts.Condition.condition result + +close() : unit + +create() : t + +object_() : Object.registry +} + +class Hash <> { + .. types .. + +hash + .. values .. + +hash_of_value() : hash + +hash_equals() : bool + +bytes_of_hash() : bytes +} + +class Identity <> { + .. values .. + +permits() : bool + +can_open() : bool + +can_close() : bool +} + +class LMDB <> { +} + +class Lifecycle <> { + .. types .. + +tree + +disposal + .. values .. + +monitor() : tree + +pin() : tree + +unpin() : tree + +is_eligible_for_gc() : bool + +contention() : bool + +unmonitor() : tree * disposal BatFingerTree.t, Concepts.Condition.condi... + +collect() : tree * disposal BatFingerTree.t, Concepts.Condition.condi... +} + +class Namespace <> { + .. types .. + +tree + .. values .. + +resolve() : Concepts.Path.t, Concepts.Condition.condition result +} + +class Object <> { + .. types .. + +multigroup + +relation + +ephemeral_relation + +transaction + +session + +branch + +branch_tree + +rnt_object_kind + +namespace + +rnt_method + +rnt_object + +registry + +rnt_object_tree + .. values .. + +make_object() + +root() + +find() + +update() + +reference_edges() + +adjust_references() + +is_gc_exempt() + +is_runtime() + +has_children() + +register() + +with_namespace() + +construct_multigroup() + +construct_relation() + +unregister() +} + +class Path <> { + .. types .. + +t + .. values .. + +empty() : t + +of_list() : t + +to_list() : string list + +snoc() : t + +to_string() : string + +is_prefix() : bool +} + +class Representation <> { + .. types .. + +blob + .. values .. + +blob_of_value() : blob + +value_of_blob() : Value.value + +blob_of_bytes() : blob + +bytes_of_blob() : bytes +} + +class Storage <> { + .. types .. + +connection + +transaction +} + +class Tuple <> { + .. types .. + +t + .. values .. + +empty() : t + +access() : Value.value option + +merge() : t + +project() : t + +rename() : t +} + +class Utilities <> { + .. values .. + +"let*" + +fmap() : 'b, 'e result +} + +class Value <> { + .. types .. + +value + .. values .. + +to_string() : string + +equal() : bool +} + +Condition --> Value +Configuration --> Condition +Cursor ..> Condition +Cursor ..> Path +Cursor *-- Storage +Cursor ..> Tuple +Cursor ..> Value +FOL ..> Condition +FOL ..> Path +FOL --> Tuple +FOL ..> Value +Handle --> Condition +Handle *-- Cursor +Handle --> Object +Handle ..> Path +Handle *-- Storage +Handle ..> Tuple +Handle ..> Value +Hash ..> Value +Identity ..> Object +LMDB ..> Condition +LMDB --> Configuration +LMDB --> Hash +LMDB --> Representation +LMDB ..> Storage +LMDB ..> Value +Lifecycle ..> Condition +Lifecycle --> Object +Lifecycle ..> Path +Namespace ..> Condition +Namespace ..> Object +Namespace ..> Path +Namespace *-- Storage +Object --> Condition +Object --> Path +Object ..> Value +Representation ..> Value +Storage ..> Condition +Storage ..> Configuration +Storage ..> Hash +Storage ..> Representation +Tuple ..> Value + +legend right + diamond A *-- B : functor composition (@composes) + solid A --> B : declared call (@uses) + dashed A ..> B : type-only coupling (@needs) +endlegend +@enduml diff --git a/lib/abstract/Storage.ml b/lib/abstract/Storage.ml index 2358c67..5eaeba3 100644 --- a/lib/abstract/Storage.ml +++ b/lib/abstract/Storage.ml @@ -1,3 +1,8 @@ +(* @needs Configuration *) +(* @needs Condition *) +(* @needs Hash *) +(* @needs Representation *) + module type STORAGE = sig type connection type transaction diff --git a/lib/backend/execution/FOL.ml b/lib/backend/execution/FOL.ml index 302285d..7da890d 100644 --- a/lib/backend/execution/FOL.ml +++ b/lib/backend/execution/FOL.ml @@ -1,3 +1,8 @@ +(* @uses Tuple -- project, rename, merge over result streams *) +(* @needs Value *) +(* @needs Path *) +(* @needs Condition *) + module Plan = struct type path_arg = Var of string | Const of Concepts.Value.value diff --git a/lib/backend/managers/Cursor.ml b/lib/backend/managers/Cursor.ml index 474387a..7fdbb6f 100644 --- a/lib/backend/managers/Cursor.ml +++ b/lib/backend/managers/Cursor.ml @@ -1,3 +1,9 @@ +(* @composes Storage -- functor parameter *) +(* @needs Path *) +(* @needs Tuple *) +(* @needs Value *) +(* @needs Condition *) + type descriptor = | Stored of {merkle_root: string} | Ephemeral of {merkle_root: string; dependencies: Concepts.Path.t BatFingerTree.t} diff --git a/lib/backend/managers/Handle.ml b/lib/backend/managers/Handle.ml index 872af43..be84972 100644 --- a/lib/backend/managers/Handle.ml +++ b/lib/backend/managers/Handle.ml @@ -1,3 +1,11 @@ +(* @composes Storage -- functor parameter *) +(* @composes Cursor -- applies Cursor.Make (Store) *) +(* @uses Object -- find, registry/kind inspection *) +(* @uses Condition -- builds not-a-relation / no-such-object errors *) +(* @needs Path *) +(* @needs Tuple *) +(* @needs Value *) + module type HANDLER = sig type t type handle diff --git a/lib/backend/managers/Identity.ml b/lib/backend/managers/Identity.ml index 3510e3a..bfde226 100644 --- a/lib/backend/managers/Identity.ml +++ b/lib/backend/managers/Identity.ml @@ -1,3 +1,5 @@ +(* @needs Object *) + let permits (object_ : Object.registry) (method_ : Object.rnt_method) : bool = BatSet.mem method_ object_.Object.entry.Object.methods diff --git a/lib/backend/managers/Lifecycle.ml b/lib/backend/managers/Lifecycle.ml index 7aa3836..d104249 100644 --- a/lib/backend/managers/Lifecycle.ml +++ b/lib/backend/managers/Lifecycle.ml @@ -8,6 +8,10 @@ the manager surfaces those to the caller as disposals rather than acting on storage itself. *) +(* @uses Object -- find/update, unregister, reference_edges, has_children *) +(* @needs Path *) +(* @needs Condition *) + type tree = Object.rnt_object_tree (* A runtime object that was collected and now needs an external teardown the diff --git a/lib/backend/managers/Namespace.ml b/lib/backend/managers/Namespace.ml index 61b1eff..a48fef9 100644 --- a/lib/backend/managers/Namespace.ml +++ b/lib/backend/managers/Namespace.ml @@ -1,3 +1,8 @@ +(* @composes Storage -- functor parameter *) +(* @needs Object *) +(* @needs Path *) +(* @needs Condition *) + module Make (Store : Abstract.Storage.STORAGE) = struct type tree = Object.rnt_object_tree diff --git a/lib/backend/managers/Object.ml b/lib/backend/managers/Object.ml index 981420b..ae5f5c1 100644 --- a/lib/backend/managers/Object.ml +++ b/lib/backend/managers/Object.ml @@ -1,3 +1,7 @@ +(* @uses Path -- snoc, to_string when building registry paths *) +(* @uses Condition -- builds registry-object/path errors *) +(* @needs Value *) + type multigroup = {merkle_root: string} type relation = {merkle_root: string} diff --git a/lib/backend/storage/LMDB.ml b/lib/backend/storage/LMDB.ml index 0d7f8d0..ff5eb3d 100644 --- a/lib/backend/storage/LMDB.ml +++ b/lib/backend/storage/LMDB.ml @@ -1,3 +1,10 @@ +(* @uses Configuration -- reads config term to connect *) +(* @uses Hash -- hash keys for get/put *) +(* @uses Representation -- blob encode/decode *) +(* @needs Condition *) +(* @needs Value *) +(* @needs Storage *) + module C = struct open Ctypes open PosixTypes diff --git a/lib/concepts/Condition.ml b/lib/concepts/Condition.ml index 16f02d0..a9082ad 100644 --- a/lib/concepts/Condition.ml +++ b/lib/concepts/Condition.ml @@ -1,3 +1,5 @@ +(* @uses Value -- renders property values in to_string_hum *) + type properties = (string, Value.value) BatMap.t type ps = properties -> properties diff --git a/lib/concepts/Configuration.ml b/lib/concepts/Configuration.ml index 5ca95d5..b2c29eb 100644 --- a/lib/concepts/Configuration.ml +++ b/lib/concepts/Configuration.ml @@ -1,3 +1,5 @@ +(* @uses Condition -- builds syntax/type errors *) + open Sexplib.Sexp type term = Sexplib.Sexp.t diff --git a/lib/concepts/Hash.ml b/lib/concepts/Hash.ml index 106e731..f467ee7 100644 --- a/lib/concepts/Hash.ml +++ b/lib/concepts/Hash.ml @@ -1,3 +1,5 @@ +(* @needs Value *) + type hash = Digestif.SHA256.t let hash_of_value (v : Value.value) = diff --git a/lib/concepts/Representation.ml b/lib/concepts/Representation.ml index 856ae11..12c3624 100644 --- a/lib/concepts/Representation.ml +++ b/lib/concepts/Representation.ml @@ -1,3 +1,5 @@ +(* @needs Value *) + type blob = bytes let blob_of_bytes (b : bytes) = b diff --git a/lib/concepts/Tuple.ml b/lib/concepts/Tuple.ml index 3050c13..8fac426 100644 --- a/lib/concepts/Tuple.ml +++ b/lib/concepts/Tuple.ml @@ -1,3 +1,5 @@ +(* @needs Value *) + module AttributeMap = BatMap.String (** A tuple: a finite map from attribute name to attribute. *) diff --git a/rnt.opam b/rnt.opam index e800c05..97cdf3b 100644 --- a/rnt.opam +++ b/rnt.opam @@ -14,7 +14,6 @@ depends: [ "batteries" "digestif" "alcotest" {with-test} - "qcheck-alcotest" {with-test} "ocaml-lsp-server" {with-dev-setup} "odoc" {with-doc} ] diff --git a/tools/uml_blueprint.pl b/tools/uml_blueprint.pl new file mode 100644 index 0000000..8b40e42 --- /dev/null +++ b/tools/uml_blueprint.pl @@ -0,0 +1,271 @@ +#!/usr/bin/env perl +# +# uml_blueprint.pl — generate a PlantUML class diagram from OCaml sources. +# +# Each module (an *.ml / *.mli file) becomes a class: +# - types -> fields +# - vals -> methods (with a best-effort return type) +# +# Edges are DECLARED, not guessed. A signature has no bodies, so a call graph +# cannot be recovered from it, and scraping .ml bodies is a heuristic that lies +# on aliases, opens and functor params. Instead the author states each edge in a +# comment tag, anywhere in the module's .ml/.mli: +# +# (* @uses [-- ] *) solid A --> B : (a real call) +# (* @needs [...] *) dashed A ..> B (type-only) +# +# Example (lib/backend/managers/Lifecycle.mli): +# (* @uses Object -- calls register/unregister *) +# (* @needs Path *) +# yields: +# Lifecycle --> Object : calls register/unregister +# Lifecycle ..> Path +# +# A tag naming an unknown module is reported on stderr (typo guard for CI). +# +# Usage: perl tools/uml_blueprint.pl --src lib --out docs/architecture.puml + +use strict; +use warnings; +use File::Find (); +use Getopt::Long (); + +my $src = 'lib'; +my $out = '-'; +my $title = 'RNT Architecture'; +my $strict = 0; # --strict: exit non-zero if a tag names an unknown module +my $no_notes = 0; # --no-notes: drop @uses edge labels (pristine edges) +Getopt::Long::GetOptions( + 'src=s' => \$src, + 'out=s' => \$out, + 'title=s' => \$title, + 'strict' => \$strict, + 'no-notes' => \$no_notes, +) or die "usage: $0 [--src DIR] [--out FILE] [--title STR] [--strict] [--no-notes]\n"; + +# --------------------------------------------------------------------------- +# 1. Discover modules. A module is a capitalised *.ml / *.mli basename. +# --------------------------------------------------------------------------- +my %mod; # base => { ml => path, mli => path } +File::Find::find( + sub { + return unless -f $_; + return unless /\A([A-Z][A-Za-z0-9_']*)\.(mli?)\z/; + $mod{$1}{ $2 eq 'mli' ? 'mli' : 'ml' } = $File::Find::name; + }, + $src +); +my %known = map { $_ => 1 } keys %mod; +die "no OCaml modules found under $src\n" unless %known; + +# --------------------------------------------------------------------------- +# Helpers. +# --------------------------------------------------------------------------- +sub slurp { + my ($f) = @_; + open my $fh, '<', $f or die "$f: $!\n"; + local $/; + return <$fh>; +} + +# Remove OCaml comments (nested (* *)) and string literals, so a keyword inside +# either cannot masquerade as a member. Tags are read from the RAW text; members +# from this stripped text. +sub strip { + my ($s) = @_; + my ($i, $n, $depth, $keep) = (0, length $s, 0, ''); + while ($i < $n) { + my $two = substr($s, $i, 2); + if ($depth == 0 && $two eq '(*') { $depth = 1; $i += 2; next; } + if ($depth > 0) { + if ($two eq '(*') { $depth++; $i += 2; next; } + elsif ($two eq '*)') { $depth--; $i += 2; next; } + $i++; + next; + } + my $c = substr($s, $i, 1); + if ($c eq '"') { # skip a string literal, honouring \" escapes + $i++; + while ($i < $n) { + my $d = substr($s, $i, 1); + if ($d eq '\\') { $i += 2; next; } + elsif ($d eq '"') { $i++; last; } + $i++; + } + $keep .= ' '; + next; + } + $keep .= $c; + $i++; + } + return $keep; +} + +sub clean_name { # strip the parens off an operator val, e.g. ( |=| ) + my ($n) = @_; + $n =~ s/\A\(\s*//; + $n =~ s/\s*\)\z//; + return $n; +} + +sub ret_of { # best-effort return type: text after the last arrow + my ($s) = @_; + $s =~ s/\s+/ /g; + $s = $1 if $s =~ /.*->\s*(.*)\z/s; + $s =~ s/[(){}:]/ /g; # keep it a valid PlantUML label + $s =~ s/\s+/ /g; + $s =~ s/\A\s+|\s+\z//g; + $s = substr($s, 0, 57) . '...' if length $s > 60; + return $s; +} + +sub uniq { + my %seen; + return grep { !$seen{$_}++ } @_; +} + +# Members from a signature (.mli). +sub parse_sig { + my ($t) = @_; + my (@types, @vals); + while ($t =~ /(? ('composes', B, note) functor param / application +# @uses B [-- note] -> ('uses', B, note) declared call +# @needs B [C ...] -> ('needs', B, undef) type-only coupling +my $warned = 0; +sub parse_tags { + my ($raw, $self) = @_; + my @edges; + for my $kw (qw(composes uses)) { + while ($raw =~ /\@$kw\s+([A-Z][\w']*)\s*(?:--\s*(.+?))?\s*(?:\*\)|\R|\z)/g) { + my ($b, $note) = ($1, $2); + $note =~ s/\s+\z// if defined $note; + push @edges, [ $kw, $b, $note ]; + } + } + while ($raw =~ /\@needs\s+((?:[A-Z][\w']*[,\s]*)+)/g) { + push @edges, [ 'needs', $_, undef ] for ($1 =~ /([A-Z][\w']*)/g); + } + for my $e (@edges) { + my $b = $e->[1]; + if (!$known{$b}) { + warn "$self: \@$e->[0] names unknown module '$b'\n"; + $warned++; + } + } + return grep { $known{ $_->[1] } && $_->[1] ne $self } @edges; +} + +# --------------------------------------------------------------------------- +# 2. Build classes and edges. +# --------------------------------------------------------------------------- +my (%types, %vals, %edges); +for my $m (keys %mod) { + my $raw_sig = $mod{$m}{mli} ? slurp($mod{$m}{mli}) : ''; + my $raw_impl = $mod{$m}{ml} ? slurp($mod{$m}{ml}) : ''; + + if ($raw_sig ne '') { ($types{$m}, $vals{$m}) = parse_sig(strip($raw_sig)); } + else { ($types{$m}, $vals{$m}) = parse_impl(strip($raw_impl)); } + + # Tags may live in either file. + $edges{$m} = [ parse_tags($raw_sig, $m), parse_tags($raw_impl, $m) ]; +} + +# --------------------------------------------------------------------------- +# 3. Emit PlantUML. +# --------------------------------------------------------------------------- +my $fh; +if ($out eq '-') { $fh = \*STDOUT; } +else { open $fh, '>', $out or die "$out: $!\n"; } + +print {$fh} "\@startuml\n"; +print {$fh} "!theme toy\n"; +print {$fh} "title $title\n"; +print {$fh} "hide empty members\n"; +print {$fh} "skinparam classAttributeIconSize 0\n"; +# Orthogonal routing: straight segments with right-angle turns instead of +# curved splines. Use "polyline" for straight-but-diagonal edges instead. +print {$fh} "skinparam linetype ortho\n"; +# Keep the graph compact so it does not shrink to unreadable when fit to width, +# but leave enough gap that ortho channels do not merge. Larger font offsets the +# tighter packing. +print {$fh} "skinparam nodesep 30\n"; +print {$fh} "skinparam ranksep 50\n"; +print {$fh} "skinparam defaultFontSize 15\n"; +print {$fh} "left to right direction\n\n"; + +for my $m (sort keys %mod) { + print {$fh} "class $m <> {\n"; + my @t = uniq(@{ $types{$m} }); + if (@t) { + print {$fh} " .. types ..\n"; + print {$fh} " +$_\n" for @t; + } + my @v = uniq(map { $_->[0] } @{ $vals{$m} }); + my %ret = map { $_->[0] => $_->[1] } @{ $vals{$m} }; + if (@v) { + print {$fh} " .. values ..\n"; + for my $name (@v) { + if ($name =~ /\A[a-z_][\w']*\z/) { + print {$fh} $ret{$name} ? " +$name() : $ret{$name}\n" : " +$name()\n"; + } + else { print {$fh} " +\"$name\"\n"; } # operator, rendered flat + } + } + print {$fh} "}\n\n"; +} + +# One edge per pair: the strongest declared relation wins. +# composes (3) *-- > uses (2) --> > needs (1) ..> +my %rank = (composes => 3, uses => 2, needs => 1); +my %best; # "from|to" => [kind, note] +for my $from (sort keys %mod) { + for my $e (@{ $edges{$from} }) { + my ($kind, $to, $note) = @$e; + my $key = "$from|$to"; + next if $best{$key} && $rank{ $best{$key}[0] } >= $rank{$kind}; + $best{$key} = [ $kind, $note ]; + } +} +for my $key (sort keys %best) { + my ($from, $to) = split /\|/, $key; + my ($kind, $note) = @{ $best{$key} }; + my $arrow = $kind eq 'composes' ? '*--' : $kind eq 'uses' ? '-->' : '..>'; + my $label = (!$no_notes && defined $note && $note ne '') ? " : $note" : ''; + print {$fh} "$from $arrow $to$label\n"; +} + +print {$fh} "\nlegend right\n"; +print {$fh} " diamond A *-- B : functor composition (\@composes)\n"; +print {$fh} " solid A --> B : declared call (\@uses)\n"; +print {$fh} " dashed A ..> B : type-only coupling (\@needs)\n"; +print {$fh} "endlegend\n"; +print {$fh} "\@enduml\n"; + +close $fh if $out ne '-'; + +exit 2 if $strict && $warned; -- cgit v1.2.3