Source file dune_project_linter.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
(*********************************************************************************)
(*  Dunolint - A tool to lint and help manage files in dune projects             *)
(*  Copyright (C) 2024-2025 Mathieu Barbin <mathieu.barbin@gmail.com>            *)
(*                                                                               *)
(*  This file is part of Dunolint.                                               *)
(*                                                                               *)
(*  Dunolint is free software; 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 either version 3 of the License, or any later   *)
(*  version, with the LGPL-3.0 Linking Exception.                                *)
(*                                                                               *)
(*  Dunolint 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  *)
(*  and the file `NOTICE.md` at the root of this repository for more details.    *)
(*                                                                               *)
(*  You should have received a copy of the GNU Lesser General Public License     *)
(*  and the LGPL-3.0 Linking Exception along with this library. If not, see      *)
(*  <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.         *)
(*********************************************************************************)

module Generate_opam_files = Generate_opam_files
module Implicit_transitive_deps = Implicit_transitive_deps
module Name = Name

type t =
  { path : Relative_path.t
  ; sexps_rewriter : Sexps_rewriter.t
  }

let create ~(path : Relative_path.t) ~original_contents =
  match Sexps_rewriter.create ~path:(path :> Fpath.t) ~original_contents with
  | Error _ as error -> error
  | Ok sexps_rewriter ->
    let t = { path; sexps_rewriter } in
    Ok t
;;

let contents t = Sexps_rewriter.contents t.sexps_rewriter
let sexps_rewriter t = t.sexps_rewriter
let path t = t.path

module Stanza = struct
  type t = ..
end

type Stanza.t +=
  | Generate_opam_files of Generate_opam_files.t
  | Implicit_transitive_deps of Implicit_transitive_deps.t
  | Name of Name.t
  | Unhandled

module Linter = struct
  let of_stanza
        (type m)
        (module M : Dunolinter.Linter.S
          with type t = m
           and type predicate = Dune_project.Predicate.t)
        ~(inner_stanza : m)
        ~(stanza : Stanza.t)
        ~path
        ~original_sexp
        ~sexps_rewriter
    =
    let eval (t : m) ~predicate =
      match (predicate : Dunolint.Predicate.t) with
      | `path condition -> Dunolinter.eval_path ~path ~condition
      | `dune _ -> Dunolint.Trilang.Undefined
      | `dune_project condition ->
        Dunolint.Trilang.eval condition ~f:(fun predicate -> M.eval t ~predicate)
    in
    let enforce =
      Dunolinter.Linter.enforce
        (module Dunolint.Predicate)
        ~eval
        ~enforce:(fun t predicate ->
          match predicate with
          | Not _ -> Eval
          | T (`dune _ | `path _) -> Unapplicable
          | T (`dune_project condition) ->
            M.enforce t ~condition;
            Ok)
    in
    let eval predicate = eval inner_stanza ~predicate in
    let enforce condition = enforce inner_stanza ~condition in
    Dunolinter.Private.Stanza.create
      { stanza; path; original_sexp; sexps_rewriter; linter = T { eval; enforce } }
  ;;

  module type S = sig
    type t

    include Dunolinter.Stanza_linter.S with type t := t

    module Linter :
      Dunolinter.Linter.S with type t = t and type predicate = Dune_project.Predicate.t
  end

  type t =
    | T :
        { impl : (module S with type t = 'a)
        ; wrap : 'a -> Stanza.t
        }
        -> t

  let field_name (T { impl = (module M); _ }) = M.field_name
end

let linters =
  Linter.
    [ T { impl = (module Generate_opam_files); wrap = (fun a -> Generate_opam_files a) }
    ; T
        { impl = (module Implicit_transitive_deps)
        ; wrap = (fun a -> Implicit_transitive_deps a)
        }
    ; T { impl = (module Name); wrap = (fun a -> Name a) }
    ]
  |> Dunolinter.Linters.create ~field_name:Linter.field_name
;;

let visit t ~f =
  let sexps_rewriter = t.sexps_rewriter in
  let path = t.path in
  List.iter (Sexps_rewriter.original_sexps sexps_rewriter) ~f:(fun original_sexp ->
    match
      match original_sexp with
      | List (Atom field_name :: _) -> Dunolinter.Linters.lookup linters ~field_name
      | _ -> None
    with
    | Some (T { impl = (module M); wrap }) ->
      let inner_stanza = M.read ~sexps_rewriter ~field:original_sexp in
      f
        (Linter.of_stanza
           (module M.Linter)
           ~inner_stanza
           ~stanza:(wrap inner_stanza)
           ~path
           ~original_sexp
           ~sexps_rewriter);
      M.rewrite inner_stanza ~sexps_rewriter ~field:original_sexp
    | None ->
      f
        (Dunolinter.Private.Stanza.create
           { stanza = Unhandled; path; original_sexp; sexps_rewriter; linter = Unhandled }))
;;