bn-d / ppx_subliner / 121

pending completion

Build # 121

Build Type

Pull #31

github

Committed by

web-flow

Commit Message

Merge 221e3d9e8 into d7f64c724

Pull Request Pull Request #31: Remove the usage of `with_default_loc`

Run Details

107 of 107 new or added lines in 2 files covered. (100.0%)

505 of 557 relevant lines covered (90.66%)

24.87 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

98.39

/src/group_cmds.ml

open Ppxlib
module Ap = Attribute_parser

let suffix = "cmdliner_group_cmds"
let gen_name_str = Utils.gen_name_str suffix
let gen_name { txt = name; loc } = { txt = gen_name_str name; loc }

type info_attrs = expression Ap.Cmd_info.t

module Info = struct
  let expr_of_attrs ~loc (default_name_expr : expression) (attrs : attributes) :
      expression =
    (* get cmd info args from attributes *)
    let info_attrs =
      Ap.Cmd_info.parse attrs
      |> Ap.Cmd_info.map (Ap.to_expr "Cmdliner.Cmd.info attributes")
    in
    let name_expr =
      Option.fold ~none:default_name_expr ~some:Fun.id info_attrs.name
    in
    let args =
      let labelled =
        [
          ("deprecated", info_attrs.deprecated);
          ("man_xrefs", info_attrs.man_xrefs);
          ("man", info_attrs.man);
          ("envs", info_attrs.envs);
          ("exits", info_attrs.exits);
          ("sdocs", info_attrs.sdocs);
          ("docs", info_attrs.docs);
          ("doc", info_attrs.doc);
          ("version", info_attrs.version);
        ]
        |> List.filter_map (fun (name, expr_opt) ->
               Option.map (fun expr -> (Labelled name, expr)) expr_opt)
      and no_label = [ (Nolabel, name_expr) ] in
      labelled @ no_label
    in
    Ast_helper.Exp.apply ~loc [%expr Cmdliner.Cmd.info] args
end

(* only for types that has been derived *)
let param_term_expr_of_core_type ct =
  let loc = ct.ptyp_loc in
  let param_term_fun_expr =
    match ct.ptyp_desc with
    | Ptyp_constr (lid, []) ->
        lid |> Utils.map_lid_name Term.gen_name_str |> Ast_helper.Exp.ident ~loc
    | _ -> Location.raise_errorf ~loc "constructor argument is not supported"
  in
  [%expr [%e param_term_fun_expr] ()]

let handle_tuple_expr_of_core_type
    ~loc
    name
    (func_expr : expression)
    (cts : core_type list) =
  let names =
    List.mapi
      (fun i ct -> { txt = "v_" ^ string_of_int i; loc = ct.ptyp_loc })
      cts
  in
  let pat =
    let pats = List.map (Ast_helper.Pat.var ~loc) names in
    Ast_helper.Pat.tuple ~loc pats
  and choice_expr =
    let tuple_expr =
      names
      |> List.map Utils.longident_loc_of_name
      |> List.map (Ast_helper.Exp.ident ~loc)
      |> Ast_helper.Exp.tuple ~loc
    in
    Ast_helper.Exp.construct ~loc
      (Utils.longident_loc_of_name name)
      (Some tuple_expr)
  in
  [%expr fun [%p pat] -> [%e func_expr] [%e choice_expr]]

let make_tuple_expr_of_core_types ~loc (cts : core_type list) =
  cts
  |> List.mapi (fun i ct ->
         let loc = ct.ptyp_loc and name_str = "v_" ^ string_of_int i in
         let pat = Ast_helper.Pat.var ~loc { txt = name_str; loc }
         and ident_expr =
           Ast_helper.Exp.ident ~loc { txt = Lident name_str; loc }
         in
         (pat, ident_expr))
  |> List.split
  |> fun (pats, exprs) ->
  let pats = List.rev pats and tuple_expr = Ast_helper.Exp.tuple ~loc exprs in
  List.fold_left
    (fun acc pat -> Ast_helper.Exp.fun_ ~loc Nolabel None pat acc)
    tuple_expr pats

let handle_params_term_expr_of_const_decl
    (func_expr : expression)
    (cd : constructor_declaration) : expression * expression =
  let loc = cd.pcd_loc in
  match cd.pcd_args with
  | Pcstr_tuple [] ->
      let handle_expr =
        let choice_expr =
          Ast_helper.Exp.construct ~loc
            (Utils.longident_loc_of_name cd.pcd_name)
            None
        in
        [%expr fun () -> [%e func_expr] [%e choice_expr]]
      in
      (handle_expr, [%expr Cmdliner.Term.const ()])
  | Pcstr_tuple [ ct ] ->
      let handle_expr =
        let choice_expr =
          Ast_helper.Exp.construct ~loc
            (Utils.longident_loc_of_name cd.pcd_name)
            (Some [%expr params])
        in
        [%expr fun params -> [%e func_expr] [%e choice_expr]]
      and param_term_expr = param_term_expr_of_core_type ct in
      (handle_expr, param_term_expr)
  | Pcstr_tuple cts ->
      let handle_expr =
        handle_tuple_expr_of_core_type ~loc cd.pcd_name func_expr cts
      and param_term_expr =
        let make_tuple_expr = make_tuple_expr_of_core_types ~loc cts in
        cts
        |> List.map param_term_expr_of_core_type
        |> List.fold_left
             (fun acc param_term_expr ->
               Ast_helper.Exp.apply ~loc [%expr ( $ )]
                 [ (Nolabel, acc); (Nolabel, param_term_expr) ])
             [%expr const [%e make_tuple_expr]]
        |> fun e -> [%expr Cmdliner.Term.([%e e])]
      in
      (handle_expr, param_term_expr)
  | Pcstr_record lds ->
      let handle_expr = [%expr fun params -> [%e func_expr] params]
      and param_term_expr =
        Term.expression_of_label_decls ~loc ~const:(Some cd.pcd_name) lds
      in
      (handle_expr, param_term_expr)

let cmd_vb_expr_of_const_decl
    (func_expr : expression)
    (cd : constructor_declaration) =
  let loc = cd.pcd_loc in
  let name_str = cd.pcd_name.txt |> String.lowercase_ascii in
  let var_name = { txt = Printf.sprintf "subcmd_%s" name_str; loc } in

  let vb =
    let pat = Ast_helper.Pat.var ~loc var_name
    and expr =
      (* Cmd.info *)
      let cmd_info_expr =
        (* lower case constructor name will be the default cmd name *)
        let default_name_expr =
          name_str
          |> String.map (function '_' -> '-' | c -> c)
          |> Ast_builder.Default.estring ~loc:cd.pcd_name.loc
        in
        Info.expr_of_attrs ~loc default_name_expr cd.pcd_attributes
        (* ('params -> 'result) * 'params Term.t *)
      and handle_expr, params_term_expr =
        handle_params_term_expr_of_const_decl func_expr cd
      in
      [%expr
        let info : Cmdliner.Cmd.info = [%e cmd_info_expr]
        and handle = [%e handle_expr]
        and params_term = [%e params_term_expr] in
        Cmdliner.(Cmd.v info Term.(const handle $ params_term))]
    in
    Ast_helper.Vb.mk ~loc pat expr
  and var_expr =
    var_name |> Utils.longident_loc_of_name |> Ast_helper.Exp.ident ~loc
  in
  (vb, var_expr)

let core_type_of_type_name ~loc name =
  let ct =
    let lid = Utils.longident_loc_of_name name in
    Ast_helper.Typ.constr ~loc lid []
  in
  [%type: ([%t ct] -> 'a) -> 'a Cmdliner.Cmd.t list]

let structure_of_const_decls ~loc name (cds : constructor_declaration list) =
  let stri =
    let pat = Ast_helper.Pat.var ~loc @@ gen_name name
    and ct = core_type_of_type_name ~loc name
    and expr =
      let cmd_vbs, cmd_exprs =
        cds |> List.map (cmd_vb_expr_of_const_decl [%expr func]) |> List.split
      in
      let cmd_list_expr = Ast_builder.Default.elist ~loc cmd_exprs in
      Ast_helper.Exp.let_ ~loc Nonrecursive cmd_vbs cmd_list_expr
    in
    [%stri let ([%p pat] : [%t ct]) = fun func -> [%e expr]]
  in
  [ stri ]

let signature_of_const_decls ~loc name =
  let sigi =
    let fun_name = gen_name name and ct = core_type_of_type_name ~loc name in
    Ast_helper.Val.mk ~loc fun_name ct |> Ast_helper.Sig.value ~loc
  in
  [ sigi ]

1	open Ppxlib
2	module Ap = Attribute_parser
3
4	let suffix = "cmdliner_group_cmds"
5	let gen_name_str = Utils.gen_name_str suffix	14✔
6	let gen_name { txt = name; loc } = { txt = gen_name_str name; loc }	2✔
7
8	type info_attrs = expression Ap.Cmd_info.t
9
10	module Info = struct
11	let expr_of_attrs ~loc (default_name_expr : expression) (attrs : attributes) :
12	expression =
13	(* get cmd info args from attributes *)
14	let info_attrs =	7✔
15	Ap.Cmd_info.parse attrs
16	\|> Ap.Cmd_info.map (Ap.to_expr "Cmdliner.Cmd.info attributes")	7✔
17	in
18	let name_expr =	7✔
19	Option.fold ~none:default_name_expr ~some:Fun.id info_attrs.name
20	in
21	let args =	7✔
22	let labelled =
23	[
24	("deprecated", info_attrs.deprecated);
25	("man_xrefs", info_attrs.man_xrefs);
26	("man", info_attrs.man);
27	("envs", info_attrs.envs);
28	("exits", info_attrs.exits);
29	("sdocs", info_attrs.sdocs);
30	("docs", info_attrs.docs);
31	("doc", info_attrs.doc);
32	("version", info_attrs.version);
33	]
34	\|> List.filter_map (fun (name, expr_opt) ->	7✔
35	Option.map (fun expr -> (Labelled name, expr)) expr_opt)	2✔
36	and no_label = [ (Nolabel, name_expr) ] in
37	labelled @ no_label
38	in
39	Ast_helper.Exp.apply ~loc [%expr Cmdliner.Cmd.info] args
40	end
41
42	(* only for types that has been derived *)
43	let param_term_expr_of_core_type ct =
44	let loc = ct.ptyp_loc in	7✔
45	let param_term_fun_expr =
46	match ct.ptyp_desc with
47	\| Ptyp_constr (lid, []) ->	7✔
48	lid \|> Utils.map_lid_name Term.gen_name_str \|> Ast_helper.Exp.ident ~loc	7✔
49	\| _ -> Location.raise_errorf ~loc "constructor argument is not supported"	×
50	in
51	[%expr [%e param_term_fun_expr] ()]
52
53	let handle_tuple_expr_of_core_type
54	~loc
55	name
56	(func_expr : expression)
57	(cts : core_type list) =
58	let names =	1✔
59	List.mapi
60	(fun i ct -> { txt = "v_" ^ string_of_int i; loc = ct.ptyp_loc })	3✔
61	cts
62	in
63	let pat =	1✔
64	let pats = List.map (Ast_helper.Pat.var ~loc) names in
65	Ast_helper.Pat.tuple ~loc pats	1✔
66	and choice_expr =
67	let tuple_expr =
68	names
69	\|> List.map Utils.longident_loc_of_name
70	\|> List.map (Ast_helper.Exp.ident ~loc)	1✔
71	\|> Ast_helper.Exp.tuple ~loc	1✔
72	in
73	Ast_helper.Exp.construct ~loc	1✔
74	(Utils.longident_loc_of_name name)	1✔
75	(Some tuple_expr)
76	in
77	[%expr fun [%p pat] -> [%e func_expr] [%e choice_expr]]
78
79	let make_tuple_expr_of_core_types ~loc (cts : core_type list) =
80	cts	1✔
81	\|> List.mapi (fun i ct ->
82	let loc = ct.ptyp_loc and name_str = "v_" ^ string_of_int i in	3✔
83	let pat = Ast_helper.Pat.var ~loc { txt = name_str; loc }	3✔
84	and ident_expr =
85	Ast_helper.Exp.ident ~loc { txt = Lident name_str; loc }	3✔
86	in
87	(pat, ident_expr))
88	\|> List.split	1✔
89	\|> fun (pats, exprs) ->	1✔
90	let pats = List.rev pats and tuple_expr = Ast_helper.Exp.tuple ~loc exprs in	1✔
91	List.fold_left
92	(fun acc pat -> Ast_helper.Exp.fun_ ~loc Nolabel None pat acc)	3✔
93	tuple_expr pats
94
95	let handle_params_term_expr_of_const_decl
96	(func_expr : expression)
97	(cd : constructor_declaration) : expression * expression =
98	let loc = cd.pcd_loc in	7✔
99	match cd.pcd_args with
100	\| Pcstr_tuple [] ->	1✔
101	let handle_expr =
102	let choice_expr =
103	Ast_helper.Exp.construct ~loc
104	(Utils.longident_loc_of_name cd.pcd_name)	1✔
105	None
106	in
107	[%expr fun () -> [%e func_expr] [%e choice_expr]]
108	in
109	(handle_expr, [%expr Cmdliner.Term.const ()])
110	\| Pcstr_tuple [ ct ] ->	4✔
111	let handle_expr =
112	let choice_expr =
113	Ast_helper.Exp.construct ~loc
114	(Utils.longident_loc_of_name cd.pcd_name)	4✔
115	(Some [%expr params])
116	in
117	[%expr fun params -> [%e func_expr] [%e choice_expr]]
118	and param_term_expr = param_term_expr_of_core_type ct in	4✔
119	(handle_expr, param_term_expr)
120	\| Pcstr_tuple cts ->	1✔
121	let handle_expr =
122	handle_tuple_expr_of_core_type ~loc cd.pcd_name func_expr cts	1✔
123	and param_term_expr =
124	let make_tuple_expr = make_tuple_expr_of_core_types ~loc cts in
125	cts	1✔
126	\|> List.map param_term_expr_of_core_type
127	\|> List.fold_left	1✔
128	(fun acc param_term_expr ->
129	Ast_helper.Exp.apply ~loc [%expr ( $ )]	3✔
130	[ (Nolabel, acc); (Nolabel, param_term_expr) ])
131	[%expr const [%e make_tuple_expr]]
132	\|> fun e -> [%expr Cmdliner.Term.([%e e])]	1✔
133	in
134	(handle_expr, param_term_expr)
135	\| Pcstr_record lds ->	1✔
136	let handle_expr = [%expr fun params -> [%e func_expr] params]
137	and param_term_expr =
138	Term.expression_of_label_decls ~loc ~const:(Some cd.pcd_name) lds	1✔
139	in
140	(handle_expr, param_term_expr)
141
142	let cmd_vb_expr_of_const_decl
143	(func_expr : expression)
144	(cd : constructor_declaration) =
145	let loc = cd.pcd_loc in	7✔
146	let name_str = cd.pcd_name.txt \|> String.lowercase_ascii in
147	let var_name = { txt = Printf.sprintf "subcmd_%s" name_str; loc } in	7✔
148
149	let vb =
150	let pat = Ast_helper.Pat.var ~loc var_name	7✔
151	and expr =
152	(* Cmd.info *)
153	let cmd_info_expr =
154	(* lower case constructor name will be the default cmd name *)
155	let default_name_expr =
156	name_str
157	\|> String.map (function '_' -> '-' \| c -> c)	9✔
158	\|> Ast_builder.Default.estring ~loc:cd.pcd_name.loc	7✔
159	in
160	Info.expr_of_attrs ~loc default_name_expr cd.pcd_attributes	7✔
161	(* ('params -> 'result) * 'params Term.t *)
162	and handle_expr, params_term_expr =
163	handle_params_term_expr_of_const_decl func_expr cd	7✔
164	in
165	[%expr
166	let info : Cmdliner.Cmd.info = [%e cmd_info_expr]
167	and handle = [%e handle_expr]
168	and params_term = [%e params_term_expr] in
169	Cmdliner.(Cmd.v info Term.(const handle $ params_term))]
170	in
171	Ast_helper.Vb.mk ~loc pat expr	7✔
172	and var_expr =
173	var_name \|> Utils.longident_loc_of_name \|> Ast_helper.Exp.ident ~loc	7✔
174	in
175	(vb, var_expr)
176
177	let core_type_of_type_name ~loc name =
178	let ct =	2✔
179	let lid = Utils.longident_loc_of_name name in
180	Ast_helper.Typ.constr ~loc lid []	2✔
181	in
182	[%type: ([%t ct] -> 'a) -> 'a Cmdliner.Cmd.t list]
183
184	let structure_of_const_decls ~loc name (cds : constructor_declaration list) =
185	let stri =	1✔
186	let pat = Ast_helper.Pat.var ~loc @@ gen_name name	1✔
187	and ct = core_type_of_type_name ~loc name	1✔
188	and expr =
189	let cmd_vbs, cmd_exprs =
190	cds \|> List.map (cmd_vb_expr_of_const_decl [%expr func]) \|> List.split	1✔
191	in
192	let cmd_list_expr = Ast_builder.Default.elist ~loc cmd_exprs in	1✔
193	Ast_helper.Exp.let_ ~loc Nonrecursive cmd_vbs cmd_list_expr	1✔
194	in
195	[%stri let ([%p pat] : [%t ct]) = fun func -> [%e expr]]
196	in
197	[ stri ]
198
199	let signature_of_const_decls ~loc name =
200	let sigi =	1✔
201	let fun_name = gen_name name and ct = core_type_of_type_name ~loc name in	1✔
202	Ast_helper.Val.mk ~loc fun_name ct \|> Ast_helper.Sig.value ~loc	1✔
203	in
204	[ sigi ]

bn-d / ppx_subliner / 121

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous