Source file ppx_deriving_gt.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
(*
 * Generic Transformers PPX syntax extension.
 * Copyright (C) 2016-2019
 *   Dmitrii Kosarev aka Kakadu
 * St.Petersburg State University, JetBrains Research
 *
 *)

open Ppxlib
open GTCommon

module E = Expander.Make(PpxHelpers)

let gt_param name =
  let open Deriving.Args in
  arg name __

let r =
  let open Deriving.Args in
  map1 ~f:(List.map (fun ({txt},e) -> (txt, e)) ) @@
  pexp_record __ none

let str_type_decl : (_, _) Deriving.Generator.t =
  Deriving.Generator.make Deriving.Args.(empty +> arg "options" r)
    (fun ~loc ~path info options ->
       let module H = Expander.Make(PpxHelpers) in
       (* Expander.notify "with annotations %s" (String.concat "," info); *)

       let generator_f si =
         H.str_type_decl_many_plugins ~loc si
           (match options with
            | None -> []
            | Some xs ->
              List.map (function
                  | (Lident name, e) -> begin
                      let extra =
                        match e.pexp_desc with
                        | Pexp_record (xs,_) -> List.map (fun ({txt},b) -> txt,b) xs
                        | Pexp_ident {txt = Lident s} when s = name -> []
                        | _ -> failwith "bad argument of a plugin"
                      in
                      (name,Expander.Use extra)
                  end
                  | _ -> failwith "only lowercase identifiers are allowed"
                ) xs
           )

       in
       generator_f [] info
    )

(*
let str_type_ext : (_, _) Deriving.Generator.t =
  Deriving.Generator.make Deriving.Args.(empty +> arg "options" r)
    (fun ~loc ~path info options ->
       let module H = Expander.Make(PpxHelpers) in
       (* Expander.notify "with annotations %s" (String.concat "," info); *)
       let generator_f si =
         H.str_type_ext_many_plugins ~loc si
           (match options with
            | None -> []
            | Some xs ->
              List.map (function
                  | (Lident name, e) -> begin
                      let extra =
                        match e.pexp_desc with
                        | Pexp_record (xs,_) -> List.map (fun ({txt},b) -> txt,b) xs
                        | _ -> failwith "asdf"
                      in
                      (name,Expander.Use extra)
                  end
                  | _ -> failwith "only lowercase identifiers are allowed"
                ) xs
           )

       in
       generator_f [] info
    )
*)

let sig_type_decl : (_, _) Deriving.Generator.t =
  Deriving.Generator.make Deriving.Args.(empty +> arg "options" r)
    (fun ~loc ~path info options ->
       let module H = Expander.Make(PpxHelpers) in
       (* Expander.notify "with annotations %s" (String.concat "," info); *)
       let generator_f si =
         H.sig_type_decl_many_plugins ~loc si
           (match options with
            | None -> []
            | Some xs ->
              List.map (function
                  | (Lident name, e) ->
                    (name,Expander.Use [])
                  | _ -> failwith "only lowercase identifiers are allowed"
                ) xs
           )

       in
       generator_f [] info
    )

let () =
  (*Sys.command "notify-send 'Registering deriver' gt" |> ignore;*)
  Deriving.add
    ~str_type_decl
    ~sig_type_decl
    (* ~str_type_ext *)
    (* ~sig_type_ext *)
    "gt"
  |> Deriving.ignore