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
open! Core
open! Import
module Warning = struct
type t =
{ message : string
; here : Source_code_position.t
}
let to_string { here; message } = [%string "%{here#Source_code_position}: %{message}"]
let unfolded_constant here = { here; message = "unfolded constant" }
let state_machine1_can_be_state_machine0 here =
{ here; message = "state_machine1 can be optimized to a state_machine0" }
;;
let relative_to (base : Source_code_position.t) t =
if String.equal base.pos_fname t.here.pos_fname
then { t with here = { t.here with pos_lnum = t.here.pos_lnum - base.pos_lnum } }
else t
;;
end
let rec value_is_constant : Skeleton.Value.t -> bool =
fun { kind; _ } ->
match kind with
| Constant | Exception -> true
| Incr | Named -> false
| Cutoff { t; added_by_let_syntax = _ } -> value_is_constant t
| Mapn { inputs } -> List.for_all inputs ~f:value_is_constant
;;
let unfolded_constants_linter =
object
inherit [Warning.t list * Source_code_position.t] Skeleton.Traverse.fold as super
method! value (value : Skeleton.Value.t) (warnings, here) =
let here = Option.value value.here ~default:here in
let is_unfolded_constant =
match value.kind with
| Constant | Exception | Incr | Named -> false
| Cutoff { t; added_by_let_syntax = _ } -> value_is_constant t
| Mapn { inputs } -> List.for_all inputs ~f:value_is_constant
in
if is_unfolded_constant
then Warning.unfolded_constant here :: warnings, here
else super#value value (warnings, here)
end
;;
let state_machine1_to_state_machine0_linter =
object
inherit [Warning.t list * Source_code_position.t] Skeleton.Traverse.fold as super
method! computation computation (warnings, here) =
let here = Option.value computation.here ~default:here in
let warnings =
match computation.kind with
| Leaf1 { input; _ } ->
if value_is_constant input
then Warning.state_machine1_can_be_state_machine0 here :: warnings
else warnings
| Return _
| Leaf01 _
| Leaf0
| Leaf_incr _
| Model_cutoff _
| Sub _
| Store _
| Fetch _
| Assoc _
| Assoc_on _
| Assoc_simpl _
| Switch _
| Lazy _
| Wrap _
| With_model_resetter _
| Path
| Lifecycle _
| Identity _ -> warnings
in
super#computation computation (warnings, here)
end
;;
let list_warnings computation =
let computation = Skeleton.Computation.of_computation computation in
let default_location = Source_code_position.of_pos ("_none_", 0, 0, 0) in
let linters = [ unfolded_constants_linter; state_machine1_to_state_machine0_linter ] in
List.fold linters ~init:[] ~f:(fun warnings linter ->
let warnings, _ = linter#computation computation (warnings, default_location) in
warnings)
;;