package mdx

  1. Overview
  2. Docs

Source file label.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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
(*
 * Copyright (c) 2018 Thomas Gazagnaire <thomas@gazagnaire.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

module Relation = struct
  type t = Eq | Neq | Le | Lt | Ge | Gt

  let pp ppf = function
    | Eq -> Fmt.string ppf "="
    | Neq -> Fmt.string ppf "<>"
    | Gt -> Fmt.string ppf ">"
    | Ge -> Fmt.string ppf ">="
    | Lt -> Fmt.string ppf "<"
    | Le -> Fmt.string ppf "<="

  let compare = function
    | Eq -> ( = )
    | Neq -> ( <> )
    | Lt -> ( < )
    | Le -> ( <= )
    | Gt -> ( > )
    | Ge -> ( >= )

  let of_string = function
    | "<>" -> Neq
    | ">=" -> Ge
    | ">" -> Gt
    | "<=" -> Le
    | "<" -> Lt
    | "=" -> Eq
    | _ -> (* can not happen, filtered by the regexp *) assert false

  let re =
    let open Re in
    compile
    @@ seq
         [
           bos;
           group (rep (alt [ alnum; char '-'; char '_' ]));
           group
             (alt [ str "<="; str ">="; str "<>"; str "<"; str ">"; str "=" ]);
           group (rep any);
           eos;
         ]

  let raw_parse s =
    match Re.exec_opt re s with
    | None -> (s, None)
    | Some g -> (
        try
          let label = Re.Group.get g 1 in
          let op = of_string (Re.Group.get g 2) in
          let value = Re.Group.get g 3 in
          (label, Some (op, value))
        with Not_found -> (s, None))
end

type non_det = Nd_output | Nd_command

let default_non_det = Nd_output

type block_kind = OCaml | Cram | Toplevel | Include

(* TODO: [t] needs to be refactored because it usually is used as a [t list]
   but most of these tags are not supposed to be specified multiple times.
   There can be at most one Language_tag, similarly specifying multiple
   Block_kind and Version labels is confusing at best. [t] should probably
   be refactored to represent all labels and make sure that some labels
   can be specified 0 or 1 times, while others are indeed lists. *)

type t =
  | Dir of string
  | Source_tree of string
  | File of string
  | Part of string
  | Env of string
  | Skip
  | Non_det of non_det option
  | Version of Relation.t * Ocaml_version.t
  | Os_type of Relation.t * string
  | Set of string * string
  | Unset of string
  | Block_kind of block_kind
  (* Specifies the language tag that is specified in the [mli] syntax, if
     any. Can be left out if none is specified, in such case it will also
     not be added back. *)
  | Language_tag of string

let pp_block_kind ppf = function
  | OCaml -> Fmt.string ppf "ocaml"
  | Cram -> Fmt.string ppf "cram"
  | Toplevel -> Fmt.string ppf "toplevel"
  | Include -> Fmt.string ppf "include"

let pp ppf = function
  | Dir d -> Fmt.pf ppf "dir=%s" d
  | Source_tree s -> Fmt.pf ppf "source-tree=%s" s
  | File f -> Fmt.pf ppf "file=%s" f
  | Part p -> Fmt.pf ppf "part=%s" p
  | Env e -> Fmt.pf ppf "env=%s" e
  | Skip -> Fmt.string ppf "skip"
  | Non_det None -> Fmt.string ppf "non-deterministic"
  | Non_det (Some Nd_output) -> Fmt.string ppf "non-deterministic=output"
  | Non_det (Some Nd_command) -> Fmt.string ppf "non-deterministic=command"
  | Version (op, v) ->
      Fmt.pf ppf "version%a%a" Relation.pp op Ocaml_version.pp v
  | Os_type (op, v) -> Fmt.pf ppf "os_type%a%s" Relation.pp op v
  | Set (v, x) -> Fmt.pf ppf "set-%s=%s" v x
  | Unset x -> Fmt.pf ppf "unset-%s" x
  | Block_kind bk -> pp_block_kind ppf bk
  | Language_tag language_tag -> Fmt.string ppf language_tag

let is_prefix ~prefix s =
  let len_prefix = String.length prefix in
  if String.length s > len_prefix then
    String.equal (String.sub s 0 len_prefix) prefix
  else false

(* [is_prefix ~prefix s] is always checked before. *)
let split_prefix ~prefix s =
  let len_prefix = String.length prefix in
  String.sub s len_prefix (String.length s - len_prefix)

let non_eq_op ~label =
  Util.Result.errorf "Label `%s` requires assignment using the `=` operator."
    label

let invalid_value ~label ~allowed_values value =
  Util.Result.errorf
    "%S is not a valid value for label `%s`. Valid values are %s." value label
    (Util.String.english_conjonction allowed_values)

let doesnt_accept_value ~label ~value res =
  match value with
  | Some _ -> Util.Result.errorf "Label `%s` does not allow a value." label
  | None -> Ok res

let requires_value ~label ~value f =
  match value with
  | Some (op, v) -> f op v
  | None -> Util.Result.errorf "Label `%s` requires a value." label

let requires_eq_value ~label ~value f =
  requires_value ~label ~value (fun op value ->
      match op with Relation.Eq -> Ok (f value) | _ -> non_eq_op ~label)

let interpret label value =
  match label with
  | "skip" -> doesnt_accept_value ~label ~value Skip
  | "ocaml" -> doesnt_accept_value ~label ~value (Block_kind OCaml)
  | "cram" -> doesnt_accept_value ~label ~value (Block_kind Cram)
  | "toplevel" -> doesnt_accept_value ~label ~value (Block_kind Toplevel)
  | "include" -> doesnt_accept_value ~label ~value (Block_kind Include)
  | v when is_prefix ~prefix:"unset-" v ->
      doesnt_accept_value ~label ~value
        (Unset (split_prefix ~prefix:"unset-" v))
  | "version" ->
      requires_value ~label ~value (fun op v ->
          match Ocaml_version.of_string v with
          | Ok v -> Ok (Version (op, v))
          | Error (`Msg e) ->
              Util.Result.errorf "Invalid `version` label value: %s." e)
  | "os_type" -> requires_value ~label ~value (fun op v -> Ok (Os_type (op, v)))
  | "non-deterministic" -> (
      match value with
      | None -> Ok (Non_det None)
      | Some (Relation.Eq, "output") -> Ok (Non_det (Some Nd_output))
      | Some (Relation.Eq, "command") -> Ok (Non_det (Some Nd_command))
      | Some (Relation.Eq, v) ->
          let allowed_values = [ "<none>"; {|"command"|}; {|"output"|} ] in
          invalid_value ~label ~allowed_values v
      | Some _ -> non_eq_op ~label)
  | "dir" -> requires_eq_value ~label ~value (fun x -> Dir x)
  | "source-tree" -> requires_eq_value ~label ~value (fun x -> Source_tree x)
  | "file" -> requires_eq_value ~label ~value (fun x -> File x)
  | "part" -> requires_eq_value ~label ~value (fun x -> Part x)
  | "env" -> requires_eq_value ~label ~value (fun x -> Env x)
  | l when is_prefix ~prefix:"set-" l ->
      requires_eq_value ~label ~value (fun x ->
          Set (split_prefix ~prefix:"set-" l, x))
  | l -> Error (`Msg (Format.sprintf "`%s` is not a valid label." l))

let of_string s =
  let f acc s =
    let label, value = Relation.raw_parse s in
    match (acc, interpret label value) with
    | Ok labels, Ok label -> Ok (label :: labels)
    | Error msgs, Ok _ -> Error msgs
    | Ok _, Error msg -> Error [ msg ]
    | Error msgs, Error msg -> Error (msg :: msgs)
  in
  match s with
  | "" -> Ok []
  | s -> (
      let split = String.split_on_char ',' s in
      match List.fold_left f (Ok []) split with
      | Ok labels -> Ok (List.rev labels)
      | Error msgs -> Error (List.rev msgs))
OCaml

Innovation. Community. Security.