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
|
(* TyXML
* http://www.ocsigen.org/tyxml
* Copyright (C) 2016 Anton Bachin
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02110-1301, USA.
*)
open Ppxlib.Ast_helper
open Ppxlib.Parsetree
(** Lang utilities *)
type lang = Html | Svg
type name = lang * string
let html_implementation = ref "Html"
let svg_implementation = ref "Svg"
let implemenentation_ref = function
| Html -> html_implementation
| Svg -> svg_implementation
let set_implementation lang s =
(implemenentation_ref lang) := s
let implementation lang =
!(implemenentation_ref lang)
let lang = function
| Html -> "HTML"
| Svg -> "SVG"
let make_lid ~loc i s =
{ txt =
(Longident.parse @@ implementation i ^ "." ^ s);
loc }
let make ~loc i s =
Exp.ident ~loc @@ make_lid ~loc i s
(** Generic *)
let find f l =
try Some (List.find f l)
with Not_found -> None
let error loc ppf =
(* Originally written by @Drup in 24d87befcc505a9e3a1b081849b12560ce38028f. *)
(* We use a custom implementation because the type of Location.raise_errorf
changed in 4.03 *)
let buf = Buffer.create 17 in
let fmt = Format.formatter_of_buffer buf in
Format.kfprintf
(fun _ ->
Format.pp_print_flush fmt ();
Location.raise_errorf ~loc "%s@." (Buffer.contents buf))
fmt
ppf
(** Ast manipulation *)
let int loc = Ast_builder.Default.eint ~loc
let float loc fl = Ast_builder.Default.efloat ~loc @@ string_of_float fl
let string loc = Ast_builder.Default.estring ~loc
let add_constraints ~list lang e =
let loc = {e.pexp_loc with loc_ghost = true} in
let elt = make_lid ~loc lang "elt" in
let wrap =
if list then make_lid ~loc lang "list_wrap"
else make_lid ~loc lang "wrap"
in
let ty =
Typ.(constr ~loc wrap [ constr ~loc elt [any ~loc ()]])
in
Exp.constraint_ ~loc e ty
type 'a value =
| Val of 'a
| Antiquot of expression
let value x = Val x
let antiquot e = Antiquot e
let map_value f = function
| Val x -> Val (f x)
| Antiquot x -> Antiquot x
let list_gen cons append nil l =
let f acc = function
| Val x -> cons acc x
| Antiquot e -> append acc e
in
(l |> List.rev |> List.fold_left f nil)
let list loc l =
let nil = [%expr []][@metaloc loc] in
let cons acc x = [%expr [%e x]::[%e acc]][@metaloc loc] in
let append acc x = [%expr [%e x]@[%e acc]][@metaloc loc] in
list_gen cons append nil @@ List.map (fun x -> Val x) l
let list_wrap_value lang loc =
let (!!) = make ~loc lang in
let nil =
[%expr
[%e !!"Xml.W.nil"]
()] [@metaloc loc]
in
let cons acc x =
[%expr [%e !!"Xml.W.cons"]
([%e !!"Xml.W.return"] [%e x])
[%e acc]
][@metaloc loc]
in
let append acc x =
[%expr
[%e !!"Xml.W.append"]
[%e add_constraints ~list:true lang x] [%e acc]
][@metaloc loc]
in
list_gen cons append nil
let list_wrap lang loc l =
list_wrap_value lang loc @@ List.map (fun x -> Val x) l
let wrap implementation loc e =
[%expr
[%e make ~loc implementation "Xml.W.return"]
[%e e]] [@metaloc loc]
let wrap_value lang loc = function
| Val x -> wrap lang loc x
| Antiquot e -> add_constraints ~list:false lang e
let txt ~loc ~lang s =
let txt = make ~loc lang "txt" in
let arg = wrap lang loc @@ string loc s in
Ast_helper.Exp.apply ~loc txt [Nolabel, arg]
|
