package bonsai

  1. Overview
  2. Docs
package bonsai
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file annotate_incr.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
open! Core
module Incr = Ui_incr
module Color = Tailwind_colors

let enabled = ref false
let enable () = enabled := true
let disable () = enabled := false
let empty_attrs = String.Map.empty

let attribute_packed pos t =
  let pos =
    pos
    |> Source_code_position.to_string
    |> String.chop_prefix_if_exists ~prefix:"lib/"
    |> String.chop_prefix_if_exists ~prefix:"app/"
  in
  let labels =
    match String.rsplit2 ~on:'/' pos with
    | Some (l, r) -> [ "bound: " ^ l; "bound: " ^ r ]
    | None -> [ pos ]
  in
  List.iter labels ~f:(fun label ->
    let label = [ label ] in
    Incr.Packed.append_user_info_graphviz t ~label ~attrs:empty_attrs)
;;

module Kind = struct
  module T = struct
    type t =
      | Input
      | Value
      | Result
      | Lifecycle
      | Empty_lifecycle
      | Model
      | Model_and_input
      | Assoc_key
      | Assoc_input
      | Assoc_results
      | Assoc_lifecycles
      | Assoc_inputs
      | Path
      | Lifecycle_apply_action_pair
    [@@deriving hash, compare, sexp]
  end

  include T
  include Hashable.Make (T)

  let name = function
    | Input -> "input"
    | Value -> "value"
    | Result -> "result"
    | Lifecycle -> "lifecycle"
    | Empty_lifecycle -> "empty lifecycle"
    | Model -> "model"
    | Model_and_input -> "model & input"
    | Assoc_key -> "assoc key"
    | Assoc_input -> "assoc input"
    | Assoc_results -> "assoc result map"
    | Assoc_lifecycles -> "assoc lifecycle map"
    | Assoc_inputs -> "assoc input map"
    | Path -> "path"
    | Lifecycle_apply_action_pair -> "lifecycle/apply-action pair"
  ;;

  let color = function
    (* results
       red *)
    | Value -> Color.red50
    | Result -> Color.red100
    | Assoc_results -> Color.red200
    | Path -> Color.red300
    (* input
       amber *)
    | Input -> Color.amber100
    | Assoc_inputs -> Color.amber200
    (* lifecycles
       blue *)
    | Lifecycle -> Color.blue100
    | Assoc_lifecycles -> Color.blue200
    | Empty_lifecycle -> Color.blue300
    (* models
       green *)
    | Model -> Color.emerald100
    | Lifecycle_apply_action_pair -> Color.emerald200
    (* assoc-related
       pink *)
    | Model_and_input -> Color.pink100
    | Assoc_key -> Color.pink200
    | Assoc_input -> Color.pink300
  ;;
end

let annotate_packed =
  Memo.general ~hashable:Kind.hashable (fun kind incr ->
    let label = [ Kind.name kind ] in
    let (`Hex color) = Kind.color kind in
    let attrs = String.Map.of_alist_exn [ "style", "filled"; "fillcolor", color ] in
    Incr.Packed.append_user_info_graphviz incr ~label ~attrs)
;;

(* The "is enabled" check are performed here in order to avoid
   going through the memoization or allocation of a Packed.t even
   when disabled. *)
let annotate_packed kind incr = if !enabled then annotate_packed kind incr
let annotate kind incr = if !enabled then annotate_packed kind (Incr.pack incr)

let attribute_packed pos_opt t =
  match !enabled, pos_opt with
  | true, Some pos -> attribute_packed pos t
  | _ -> ()
;;

let attribute pos_opt incr = if !enabled then attribute_packed pos_opt (Incr.pack incr)
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