Source file capitalization_ppx_configuration.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
open! Base
open! Ppxlib

let raise_invalid_arg message ~loc ~ppx_name ~options =
  let options_name, options = options in
  (* This inserts break hints between the options for much nicer multi-line error
     formatting.

     The compiler seems to do this automatically for error extension nodes but we need to
     do it ourselves when raising located errors, like here. *)
  let options_format =
    Stdlib.Scanf.format_from_string (String.concat options ~sep:",@ ") ""
  in
  Location.raise_errorf
    ~loc
    "@[<v>%s: %(%)@ (@[%s: %(%))@]@]"
    ppx_name
    message
    options_name
    options_format
;;

module Single_word = struct
  type t =
    { capitalization : Capitalization.Single_word.t
    ; (* Metadata for errors *)
      arg_location : Location.t
    ; ppx_name : string
    }

  let%template potential_options single_word =
    List.filter Capitalization.all ~f:(fun capitalization ->
      ([%equal: Capitalization.Single_word.t] [@mode local])
        single_word
        (Capitalization.first_word_behavior capitalization))
  ;;

  let raise_incompatible t message =
    let { capitalization; ppx_name; arg_location } = t in
    let options =
      potential_options capitalization |> List.map ~f:Capitalization.to_string
    in
    raise_invalid_arg
      ~loc:arg_location
      message
      ~ppx_name
      ~options:("potential options", options)
  ;;

  let apply_exn t s =
    match String.mem s '_' with
    | false -> Capitalization.Single_word.apply_to_word t.capitalization s
    | true ->
      raise_incompatible t "capitalize argument must specify multiple word behavior"
  ;;
end

type t =
  | Multi_word of Capitalization.t
  | Single_word of Single_word.t

let of_string_opt { loc; txt } ~ppx_name =
  match Capitalization.of_string txt with
  | x -> Some (Multi_word x)
  | exception _ ->
    (match Capitalization.Single_word.of_string txt with
     | x -> Some (Single_word { capitalization = x; arg_location = loc; ppx_name })
     | exception _ -> None)
;;

let argument_name = "capitalize"

let argument ~ppx_name =
  let open Deriving.Args in
  arg
    argument_name
    (map1 (estring __') ~f:(fun s ->
       match of_string_opt s ~ppx_name with
       | Some x -> x
       | None ->
         let can_be = Lazy.force Capitalization.can_be in
         raise_invalid_arg
           "invalid capitalize argument"
           ~loc:s.loc
           ~ppx_name
           ~options:("can be", can_be)))
;;

let apply_to_snake_case_exn t s =
  match t with
  | Multi_word c -> Capitalization.apply_to_snake_case c s
  | Single_word x -> Single_word.apply_exn x s
;;