Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 422 lines (359 sloc) 15.283 kB
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support…
OpaOnWindowsNow authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* @author Rudy Sicard *)
19 (*
20 Can be before renaming,
21
22 For internationalisation, when generating template
23 replace @i18n(@string(["computed_",@magic_to_string{"string"),"_yo"]) by
24 generated_fun(@magic_to_string{"string")) and collect generated_fun
25 or remove @i18n when no internationalisation package is known
26 replace @i18n(something) by something(@i18_lang)
27
28
29 Should be after renaming
30 After renaming
31 For computed String, when not generating template
32 replace @string(["computed_",@magic_to_string{"string"),"_yo"]) by sc_list(["computed_",@magic_to_string{"string"),"_yo"])
33
34 replace @i18n_lang by the relevant library call
35
36
37 For performance reason we group both @i18n and @string process, so everything is with uid
38
39 *)
0c152d9 @OpaOnWindowsNow [fix] I18n: avoid duplicate entry in template translation package gen…
OpaOnWindowsNow authored
40 let (|>) a f = f a
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support…
OpaOnWindowsNow authored
41
42 let i18n_pkg_name = "stdlib.core.i18n"
43 let default_pkg_ext = ".translation"
44 let linking_pkg_name = "linking"
45
46 let i18n_warn =
47 WarningClass.create
48 ~public:true
49 ~name:"i18n"
50 ~doc:"All i18n related warnings"
51 ~err:false
52 ~enable:true
53 ()
54
55 let i18n_warn_existing =
56 WarningClass.create
57 ~parent:i18n_warn
58 ~public:true
59 ~name:"existing-package"
60 ~doc:"Warn if the i18n-template is generated while an old version of the template is still there"
61 ~err:false
62 ~enable:true
63 ()
64
65 let i18n_warn_missing =
66 WarningClass.create
67 ~parent:i18n_warn
68 ~public:true
69 ~name:"missing"
70 ~doc:"Warn for missing translation"
71 ~err:false
72 ~enable:true
73 ()
74
75 let i18n_warn_missing_template =
76 WarningClass.create
77 ~parent:i18n_warn_missing
78 ~public:true
79 ~name:"template"
80 ~doc:"Warn if a i18n-template is missing"
81 ~err:false
82 ~enable:true
83 ()
84
85 let i18n_warn_missing_translation_package =
86 WarningClass.create
87 ~parent:i18n_warn_missing
88 ~public:true
89 ~name:"package"
90 ~doc:"Warn if a translation package is missing"
91 ~err:true
92 ~enable:true
93 ()
94
95
96
97 let warning_set =
98 WarningClass.Set.create_from_list [
99 i18n_warn;
100 i18n_warn_existing;
101 i18n_warn_missing_template;
102 ]
103
104 module SA = SurfaceAst
105 module SAC = SurfaceAstCons.ExprIdentCons
106
107 let copy_label v = {v with QmlLoc.notes = SurfaceAstCons.Fresh.id ()}
108
109 (* generate a call to directive i18n_lang (or equivalent form *)
110 (* when cleaning of js code must be done, shoud really use the directive to simplify code analysis *)
111 let i18n_lang () =
112 let i18n_lang = SAC.E.ident (OpaMapToIdent.val_ Opacapi.I18n.lang) in
113 SAC.E.applys i18n_lang []
114 (* SAC.D.i18n_lang() *)
115 (* SAC.E.string "WTF" *)
116
117
118 (* generate a call to String.flatten with the given expr list as parameter, need with_label *)
119 let flattened_string expr_list =
120 match expr_list with
121 | hd :: [] -> hd
122 | hd :: _ ->
123 SurfaceAstCons.with_same_pos hd (fun() ->
124 let flatten = SAC.E.ident (OpaMapToIdent.val_ Opacapi.String.flatten) in
125 let expr_list = SAC.E.list expr_list in
126 let flattened = SAC.E.applys flatten [expr_list] in
127 flattened
128 )
129 | _ -> failwith "Empty flattened_string list"
130
131 (* separate constant part and parameter part (inserts) of a string *)
132 let consts_and_expressions expr_list =
133 List.partition (function
134 |SA.Const SA.CString _,_ -> true
135 |SA.Directive _,_ -> false
136 |_ -> assert false
137 ) expr_list
138
139 (* generate an ident for a computed string that depends on constant part of the string and on inserts positions *)
140 let translation_fun_ident consts =
141 let digest = List.fold_left (fun acc e->
142 match e with
143 |SA.Const SA.CString s,_ -> Digest.string (acc ^ s)
144 |_ -> assert false
145 ) "" consts
146 in Printf.sprintf "__i18n_%s" (Digest.to_hex digest)
147
148 (* adding a source ident here is ok when it is used to generate template file *)
149 let template_ident_cons = Ident.source
150
151 let translation_fun_body_default_case default_expr =
152 let default_ident = template_ident_cons "_default" in
153 let pat = SAC.P.var default_ident in
154 (pat,default_expr)
155
156 (* substitute non const string expression by parameters *)
157 let subst_parameters expr_list parameters =
158 let _, expr_list = Base.List.fold_left_map (fun acc e->
159 match e with
160 |SA.Const SA.CString _,_ -> acc,e
161 | _ -> List.tl acc,(List.hd acc)
162 ) parameters expr_list
163 in expr_list
164
165 type ('a,'b) translation_fun = {
166 id : string;
167 parameters : string list; (* string or something else *)
168 initial_expr : ('a,'b) SurfaceAst.expr;
169 default_expr : ('a,'b) SurfaceAst.expr;
170 body : ('a,'b) SurfaceAst.expr;
171 }
172
173 (* generate a translation body given the number of parameter and initial computed string, need with_label *)
174 let translation_fun_body initial_expr expr_list ()=
175 let (consts,expressions) = consts_and_expressions expr_list in
176 let nb_parameters = List.length expressions in
177 let parameters = Base.List.init nb_parameters (fun i-> Printf.sprintf "p%d" (i+1)) in
178 let args = List.map template_ident_cons parameters in
179 let lambda_args = List.map SAC.P.var args in
180 let string_inserts = List.map SAC.E.ident args in
181 let default_expr = SAC.D.string (subst_parameters expr_list string_inserts) in
182 let default_pattern_case = translation_fun_body_default_case default_expr in
183 let match_ = SAC.E.match_ (i18n_lang()) [default_pattern_case] in
184 let body = SAC.E.lambda lambda_args match_ in
185 {
186 id = translation_fun_ident consts;
187 parameters;
188 body ; default_expr ; initial_expr
189 }
190
191 let collect_directives__i18n acc code =
192 let fold (acc,v) f = OpaWalk.Code.fold f acc v in
193 let process e expr_list = SurfaceAstCons.with_label (snd e)
194 (translation_fun_body e expr_list)
195 in
196 let collect acc code =
197 fold(acc,code)(fun acc (e,_) ->
198 match e with
199 (* @i18n("...") ==> add template translation package *)
200 | SA.Directive (`i18n , [SA.Directive (`string, expr_list, _),_ as e], _) -> (process e expr_list)::acc
201 | SA.Directive (`i18n , [SA.Const (SA.CString _) ,_ as e], _) -> (process e [e] )::acc
202 | _ -> acc
203 )
204 in
205 collect acc code
206
207 let warn_missing_template e i18n_dir i18n_pkg str_ident =
208 QmlError.warning ~wclass:i18n_warn_missing_template (QmlError.Context.pos (QmlLoc.pos (snd e)))
209 "A translation function is missing (%s),\nplease regenerate translation template packages:\n %a {%a}/*.opa"
210 str_ident
211 (Base.Format.pp_list "@," Base.Format.pp_print_string) i18n_pkg
212 (Base.Format.pp_list "@," Base.Format.pp_print_string) i18n_dir
213
214 (* replace @i18n and @string directives by calls to the proper functions (String.flatten or translation) *)
215 let replace_directives__i18n__string ~i18n_dir ~i18n_pkg code =
216 let enable_i18n = i18n_dir <> [] || i18n_pkg <> [] in
217 let map v f = OpaWalk.Code.map_down f v in
218 let translate expr_list = SurfaceAstCons.with_same_pos (List.hd expr_list) (fun()->
219 let (consts,expressions) = consts_and_expressions expr_list in
220 let str_ident = translation_fun_ident consts in
221 try
222 let ident = OpaMapToIdent.val_no_opacapi_check str_ident in
223 let translation_fun_ident = SAC.E.ident ident in
224 let translated = SAC.E.applys translation_fun_ident expressions in
225 translated
226 with Not_found -> (
227 (* template not available, ignore @i18n mode *)
228 warn_missing_template (List.hd expr_list) i18n_dir i18n_pkg str_ident;
229 flattened_string expr_list
230 )
231 )
232 in
233 let process = if enable_i18n then translate else flattened_string in
234 let rewrite code =
235 map(code)(fun ((e,label) as v) ->
236 match e with
237 (* "..." ==> String_flatten(...) *)
238 | SA.Directive (`string, [] , _) -> SAC.E.string ~label ""
239 | SA.Directive (`string, expr_list, _) -> flattened_string expr_list
240
241 (* @i18n("...") ==> String_flatten(...) OR translate_fun(parameters) *)
242 | SA.Directive (`i18n , [SA.Directive (`string, expr_list, _),_], _) -> process expr_list
243 | SA.Directive (`i18n , [SA.Const (SA.CString _),_ as string ], _) -> process [string]
244
245 (* @i18n(expr) => expr(@i18n_lang) *)
246 | SA.Directive (`i18n , [expr], _ ) -> SurfaceAstCons.with_label label (fun()->
247 SAC.E.applys expr [i18n_lang ()]
248 )
249
250 | SA.Directive (`i18n , _ , _ ) -> assert false
251 | _ -> v
252 )
253 in
254 rewrite code
255
256 let pos_get_line pos = snd (FilePos.get_one_loc pos)
257
258 (* header of one translation entry *)
259 let generate_template_header f tf =
260 let pos = QmlLoc.pos (snd tf.initial_expr) in
261 Format.fprintf f "// Template for %s\n" (FilePos.get_file pos);
262 Format.fprintf f "// %a\n" OpaPrint.readable_ident#expr tf.default_expr; (* printing e here can have some drawbacks, need to be solved => use string extracts ? *)
263 Format.fprintf f "// string, %d\n" (pos_get_line pos)
264
265
266 let pp_parameter f s = Base.Format.fprintf f "%s:string" s
267
268 (* a translation function in opa, pure string *)
269 let generate_declaration_custom f tf =
270 Format.fprintf f "%s(%a)= match I18n.lang()\n" tf.id (Base.Format.pp_list "," pp_parameter) tf.parameters;
271 (*"{123} ->"*)
272 Format.fprintf f " _ -> %a" OpaPrint.readable_ident#expr tf.default_expr
273
274 (* same from an AST *)
275 let generate_declaration f tf =
276 let pat_id = SurfaceAstCons.with_same_pos tf.initial_expr (fun()-> SAC.P.var (template_ident_cons tf.id)) in
277 Format.fprintf f "%a\n\n" OpaPrint.readable_ident#code_elt_node (SA.NewVal ([pat_id,tf.body],false))
278
279 (* generate the source of a translation package *)
280 let generate_opa_file name collection target =
281 let f = Format.formatter_of_out_channel target in
282 Format.fprintf f "package %s\n" name;
283 Format.fprintf f "import %s\n" i18n_pkg_name;
284 List.iter (fun tf ->
285 (* here should check for an already present definition in old file *)
286 Format.fprintf f "\n";
287 generate_template_header f tf;
288 generate_declaration_custom f tf;
289 Format.fprintf f "\n\n";
290 ) collection
291
292 (* TODO, if an Opa file already exists, then parse it and use it to extract code verbatim or make a merge thing *)
293 (* let _merge_opa_file name collection target old = assert false *)
294
295 let generate_po_file collection =
296 let f = Format.formatter_of_out_channel stdout in
297 List.iter (fun tf ->
298 generate_template_header f tf;
299 Format.printf "\nmsgid \"%a\"\n" OpaPrint.readable_ident#expr tf.default_expr;
300 Format.printf "msgstr \"\"\n\n";
301 ) collection
302
303 let current_package ?package () =
304 let package = match package with
305 | Some package -> package
306 | None -> ObjectFiles.get_current_package_name()
307 in if package="" then linking_pkg_name else package
308
309 let default_i18n_package ?package () = (current_package ?package ())^default_pkg_ext
310
311 module I18n = OpaEnv.I18n
312
313 let need_to_import_package ~options =
314 let open I18n.Type in (* for I18n fields *)
315 let opt = options.OpaEnv.i18n in
316 (opt.pkg<> [] || opt.dir<>[]) && not(opt.template_opa || opt.template_po)
317
318 let warn_missing_package initial_package i18n_package =
319 QmlError.warning ~wclass:i18n_warn_missing_translation_package
320 (QmlError.Context.package initial_package)
321 "Translation package %s is needed (by %s) but not provided"
322 i18n_package
323 initial_package
324
325 let import_package ?package ~exists ~options =
326 let open I18n.Type in (* for I18n fields *)
327 let should_import =
328 match options.OpaEnv.i18n.pkg with
329 | [] -> [default_i18n_package ?package ()]
330 | v -> v
331 in List.filter (fun i18n_package ->
332 if exists i18n_package then true
333 else (
334 warn_missing_package (current_package ?package()) i18n_package;
335 false
336 )
337 ) should_import
338
339 let may_import_package ?package ~exists ~options =
340 if need_to_import_package ~options then (
341 let ps = import_package ?package ~exists ~options in
342 (*if ps <> [] then Base.Format.printf "I18n: importing %a\n" (Base.Format.pp_list "," Base.Format.pp_print_string) ps;*)
343 ps
344 ) else []
345
346 let backup_existing name =
347 try
348 let stat = Unix.stat name in
349 let nname = Printf.sprintf "%s.%d" name (int_of_float stat.Unix.st_atime) in
350 Unix.rename name nname;
351 Some(nname)
352 with Unix.Unix_error(Unix.ENOENT,_,_) -> None
353
354 let with_file conflict name f =
355 let name = PathTransform.string_to_mysys name in
356 let backup = backup_existing name in
357 let c = open_out name in
358 (try f c with _ -> ());
359 close_out c;
360 match backup with
361 | None -> ()
362 | Some b -> conflict name b
363
364
365 module SAP = SurfaceAstPassesTypes
366 let replace_directives__i18n__string ~i18n_dir ~i18n_pkg env =
367 let lcodeNotUser = replace_directives__i18n__string ~i18n_dir ~i18n_pkg env.SAP.lcodeNotUser in
368 let lcodeUser = replace_directives__i18n__string ~i18n_dir ~i18n_pkg env.SAP.lcodeUser in
369 { env with SAP.
370 lcodeNotUser = lcodeNotUser;
371 lcodeUser = lcodeUser
372 }
373
374 let collect_directives__i18n env =
375 let acc = collect_directives__i18n [] env.SAP.lcodeNotUser in
376 let acc = collect_directives__i18n acc env.SAP.lcodeUser in
0c152d9 @OpaOnWindowsNow [fix] I18n: avoid duplicate entry in template translation package gen…
OpaOnWindowsNow authored
377 let cmp_id tf1 tf2 = Pervasives.compare tf1.id tf2.id in
378 let cmp_pos =
379 let pos tf = FilePos.get_one_loc (QmlLoc.pos (snd tf.initial_expr)) in
380 (fun tf1 tf2 -> Pervasives.compare (pos tf1) (pos tf2))
381 in
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support…
OpaOnWindowsNow authored
382 acc
0c152d9 @OpaOnWindowsNow [fix] I18n: avoid duplicate entry in template translation package gen…
OpaOnWindowsNow authored
383 |> List.stable_sort cmp_id (* need determist order (wrt initial relative order) for equal elements *)
384 |> Base.List.uniq ~cmp:cmp_id (* TODO merge position *)
385 |> List.sort cmp_pos
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support…
OpaOnWindowsNow authored
386
387 let process_directives__i18n__string ~options env =
388 let open I18n.Type in (* for I18n fields *)
389 let i18n = options.OpaEnv.i18n in
390 if OpaEnv.i18n_template options then (
391 begin match collect_directives__i18n env with
392 | [] -> ()
393 | tf :: _ as collection ->
394 let target_dir = match i18n.dir with
395 | dir :: _ -> dir
396 | [] -> "."
397 in
398 let target_package = match i18n.pkg with
399 | pkg :: _ -> pkg
400 | [] -> default_i18n_package ()
401 in
402 (* Printf.printf "I18n : Translation package name %s\n" target_package;*)
403 (* Printf.printf "I18n : Number of translation template %d\n" (List.length collection); flush stdout;*)
404 let conflict target diff new_ old_ = (* TODO use merge function here *)
405 QmlError.warning ~wclass:i18n_warn_existing (QmlError.Context.pos (QmlLoc.pos (snd tf.initial_expr)))
406 "Old version of package %s was backup in %s\nYou should merge with the new version :\n%s %s %s %s | tee %s\n"
407 target old_
408 diff new_ new_ old_ new_
409 in
410 let dest_file_opa = Printf.sprintf "%s/%s" target_dir target_package in
411 if i18n.template_opa then
412 with_file (conflict target_package "meld") (dest_file_opa^".opa") (generate_opa_file target_package collection);
413 if i18n.template_po then generate_po_file collection;
414 end;
415 exit 0
416 ) else replace_directives__i18n__string ~i18n_dir:i18n.dir ~i18n_pkg:i18n.pkg env
417
418 let process_directives__i18n_lang ~options env =
419 let _ = options in
420 env
421
Something went wrong with that request. Please try again.