Source file `ppx_optint.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
open Ppxlib
open Ast_helper

let mklid m lid =
  Exp.ident { Location.loc = !default_loc ;
              txt = Longident.Ldot (m, lid) }

let apply m f xs =
  Exp.(apply (mklid m f)
         (List.map (fun e -> Asttypes.Nolabel, e) xs))

let optint = Longident.Lident "Optint"

let optint s =
  let x = Optint.of_string s in
  if Optint.equal x Optint.zero then
    mklid optint "zero"
  else if Optint.equal x Optint.one then
    mklid optint "one"
  else if Optint.equal x Optint.minus_one then
    mklid optint "minus_one"
  else
    apply optint "of_string" [Exp.constant (Const.string s)]

let int63 = Longident.Ldot (Longident.Lident "Optint", "Int63")

let int63 s =
  let module Int63 = Optint.Int63 in
  let x = Int63.of_string s in
  if Int63.equal x Int63.zero then
    mklid int63 "zero"
  else if Int63.equal x Int63.one then
    mklid int63 "one"
  else if Int63.equal x Int63.minus_one then
    mklid int63 "minus_one"
  else
    apply int63 "of_string" [Exp.constant (Const.string s)]

let expander m f loc s =
  with_default_loc loc @@ fun () ->
  try f s
  with Failure msg ->
    (* XXX: [msg] is often not very helpful *)
    let error s =
      Exp.extension ~loc
        (Location.Error.to_extension (Location.Error.make ~loc ~sub:[] s))
    in
    Format.kasprintf error "Bad %s integer literal. %s." m msg

let () =
  Driver.register_transformation
    "ppx_optint"
    ~rules:[
      Context_free.Rule.constant Integer 'i' (expander "Optint.t" optint);
      Context_free.Rule.constant Integer 'I' (expander "Optint.Int63.t" int63);
    ]