1(* camlp5r *)
2(* $Id: translate.ml,v 5.9 2007-09-12 09:58:44 ddr Exp $ *)
3(* Copyright (c) 1998-2007 INRIA *)
4
5module Buff = Buff.Make (struct value buff = ref (Bytes.create 80); end);
6
7value skip_lang s =
8  loop where rec loop i =
9    if i = String.length s then None
10    else
11      match s.[i] with
12      [ 'a'..'z' | '-' -> loop (i + 1)
13      | _ -> Some i ]
14;
15
16value inline lang macro_char macro s =
17  let lang = lang ^ ":" in
18  let derived_lang =
19    try
20      let i = String.index lang '-' in
21      String.sub lang 0 i ^ ":"
22    with
23    [ Not_found -> "" ]
24  in
25  let rec loop alt_version bol i =
26    if i = String.length s then
27      match alt_version with
28      [ Some s -> (s, True)
29      | None -> ("..........", False) ]
30    else if bol then
31      match skip_lang s i with
32      [ Some j when s.[j] = ':' ->
33          let curr_lang = String.sub s i (j + 1 - i) in
34          if curr_lang = lang || curr_lang = derived_lang ||
35             curr_lang = "en:" then
36            let (s, i) =
37              let j = if s.[j + 1] = ' ' then j + 1 else j in
38              let rec loop len j =
39                if j = String.length s then (Buff.get len, j)
40                else if s.[j] = '\n' then
41                  if j + 1 < String.length s && s.[j + 1] = ' ' then
42                    let j =
43                      loop (j + 1) where rec loop j =
44                        if j < String.length s && s.[j] = ' ' then
45                          loop (j + 1)
46                        else j
47                    in
48                    loop (Buff.store len '\n') j
49                  else (Buff.get len, j)
50                else if s.[j] = macro_char then
51                  loop (Buff.mstore len (macro s.[j + 1])) (j + 2)
52                else loop (Buff.store len s.[j]) (j + 1)
53              in
54              loop 0 (j + 1)
55            in
56            if curr_lang = lang then (s, False)
57            else
58              let alt_version =
59                if curr_lang = derived_lang then Some s
60                else if alt_version = None then Some s
61                else alt_version
62              in
63              loop alt_version True i
64          else loop alt_version (s.[i] = '\n') (i + 1)
65      | _ -> loop alt_version (s.[i] = '\n') (i + 1) ]
66    else loop alt_version (s.[i] = '\n') (i + 1)
67  in
68  loop None True 0
69;
70
71value language_name lang lang_def =
72  let str = lang_def in
73  let len = String.length lang in
74  let rec loop beg i =
75    if i = String.length str && i = beg then lang
76    else if i = String.length str || str.[i] = '/' then
77      if i > beg + len + 1 && str.[beg + len] = '=' &&
78         String.sub str beg len = lang then
79        String.sub str (beg + len + 1) (i - beg - len - 1)
80      else if i = String.length str then lang
81      else loop (i + 1) (i + 1)
82    else loop beg (i + 1)
83  in
84  loop 0 0
85;
86
87(* eval *)
88
89value erase str i j =
90  String.sub str 0 i ^ String.sub str j (String.length str - j)
91;
92
93(*
94 * eval_set scans strings of the form @(x) where x is a list of characters
95 * meaning a predicate to set for each character. Fills [set], the set of
96 * predicates. Treats also the special case for @(&) = delete the next
97 * character if any.
98 *)
99
100value eval_set str =
101  loop [] str 0 where rec loop set str i =
102    if i + 3 < String.length str then
103      if str.[i] = '@' && str.[i + 1] = '(' && str.[i + 3] <> '?' &&
104         str.[i + 3] <> '-'
105      then
106        if str.[i + 2] = '&' && str.[i + 3] = ')' && i + 4 < String.length str
107        then
108          loop set (erase str i (i + 5)) i
109        else
110          let (set, j) =
111            loop set (i + 2) where rec loop set i =
112              if i < String.length str then
113                if str.[i] <> ')' then loop [str.[i] :: set] (i + 1)
114                else (set, i + 1)
115              else (set, i)
116          in
117          loop set (erase str i j) i
118      else loop set str (i + 1)
119    else (set, str)
120;
121
122value rec apply_expr set str i =
123  if i + 1 < String.length str && str.[i + 1] = '?' then
124    if List.mem str.[i] set then
125      let str = erase str i (i + 2) in
126      let (str, i) = apply_expr set str i in
127      if i < String.length str && str.[i] = ':' then
128        let (str, j) = apply_expr set str (i + 1) in
129        (erase str i j, i)
130      else (str, i)
131    else
132      let (str, j) = apply_expr set str (i + 2) in
133      let str = erase str i j in
134      if i < String.length str && str.[i] = ':' then
135        let str = erase str i (i + 1) in
136        apply_expr set str i
137      else (str, i)
138  else if i < String.length str && (str.[i] = ':' || str.[i] = ')') then
139    (str, i)
140  else apply_expr set str (i + 1)
141;
142
143(*
144 * eval_app scans strings matching expressions between @( and ).
145 *    an expression is:
146 *     - a [character] followed by "?", an [expression] and possibly ":" and
147 *       [another expression]
148 *     - any [string] not holding ":"
149 *    The [character] is a predicate. If defined, the first expression is
150 *    evaluated, else it is the second one. The evaluation of a string is
151 *    itself.
152 *
153 *  ex: p?e:m?A?en:er:w?e:n?es
154 *    In this example, if m and A are only defined predicates:
155 *      p not being defined, it is m?A?en:er:w?e:n?es
156 *      m being defined, it is A?en:er
157 *      A being defined, it is en
158 *    This example shows how to display adjectives in German, where
159 *    m is for masculine, w for feminine and n for neuter
160 *)
161
162value eval_app set str =
163  loop str 0 where rec loop str i =
164    if i + 3 < String.length str then
165      if str.[i] = '@' && str.[i + 1] = '(' && str.[i + 3] <> '-' then
166        let str = erase str i (i + 2) in
167        let (str, i) = apply_expr set str i in
168        if i < String.length str then
169          if str.[i] = ')' then loop (erase str i (i + 1)) i else loop str i
170        else str
171      else loop str (i + 1)
172    else str
173;
174
175(*
176 * eval_shift scans strings matching:
177 *   @(#-) shifting # words of the left after the next word.
178 *   @(#--) shifting # words of the left to the end.
179 * ex:
180 *   before: "Une avec un diamant@(3-) bague"
181 *    after: "Une bague avec un diamant"
182 *   before: "Sie haben geworfen@(1--) einen kurzen Bogen"
183 *    after: "Sie haben einen kurzen Bogen geworfen"
184 *)
185
186value rec eval_shift s =
187  let t = String.make (String.length s) '#' in
188  let rec loop changed i j =
189    if i + 4 < String.length s && s.[i] = '@' && s.[i + 1] = '(' &&
190       s.[i + 3] = '-'
191    then
192      let nleft = Char.code s.[i + 2] - Char.code '0' in
193      let to_the_end = s.[i + 4] = '-' in
194      let k = if to_the_end then i + 5 else i + 4 in
195      if k < String.length s && s.[k] = ')' then
196        let l =
197          loop nleft (i - 1) where rec loop nleft l =
198            if l > 0 then
199              if s.[l] = ' ' then
200                if nleft <= 1 then l + 1 else loop (nleft - 1) (l - 1)
201              else loop nleft (l - 1)
202            else 0
203        in
204        let len = i - l in
205        let j = j - len in
206        let k = k + 1 in
207        let i = if k < String.length s && s.[k] = ' ' then k + 1 else k in
208        let (i, j) =
209          if to_the_end then
210            let rec loop i j =
211              if i < String.length s then do {
212                Bytes.set t j s.[i]; loop (i + 1) (j + 1)
213              }
214              else do {
215                let j =
216                  if j > 0 && t.[j - 1] <> ' ' then do { Bytes.set t j ' '; j + 1 }
217                  else j
218                in
219                String.blit s l t j len;
220                (i, j + len)
221              }
222            in
223            loop i j
224          else
225            let rec loop i j =
226              if i < String.length s then
227                if s.[i] = ' ' then do {
228                  Bytes.set t j ' ';
229                  String.blit s l t (j + 1) len;
230                  (i, j + 1 + len)
231                }
232                else do { Bytes.set t j s.[i]; loop (i + 1) (j + 1) }
233              else if k < String.length s && s.[k] = ' ' then do {
234                Bytes.set t j ' '; String.blit s l t (j + 1) len; (i, j + 1 + len)
235              }
236              else do { String.blit s l t j len; (i, j + len) }
237            in
238            loop i j
239        in
240        loop True i j
241      else do { Bytes.set t j s.[i]; loop changed (i + 1) (j + 1) }
242    else if i < String.length s then do {
243      Bytes.set t j s.[i]; loop changed (i + 1) (j + 1)
244    }
245    else if changed then eval_shift (String.sub t 0 j)
246    else String.sub t 0 j
247  in
248  loop False 0 0
249;
250
251value rec eval str =
252  if not (String.contains str '@') then (* optimisation *) str
253  else
254    let str = eval_rec str in
255    let (set, str) = eval_set str in
256    let str = eval_app set str in
257    eval_shift str
258and eval_rec str =
259  loop str 0 where rec loop str i =
260    if i = String.length str then str
261    else if i + 3 < String.length str && str.[i] = '@' && str.[i+1] = '(' &&
262      str.[i+2] = '@'
263    then
264      let j =
265        loop (i + 2) where rec loop j =
266          if j < String.length str then
267            if str.[j] = '(' then
268              let j = loop (j + 1) in
269              loop (j + 1)
270            else if str.[j] = ')' then j
271            else loop (j + 1)
272          else j
273      in
274      if j = String.length str then str
275      else
276        let sstr = eval (String.sub str (i + 2) (j - i - 2)) in
277        let k = i + String.length sstr in
278        let str =
279          String.sub str 0 i ^ sstr ^
280            String.sub str (j + 1) (String.length str - j - 1)
281        in
282        loop str k
283    else loop str (i + 1)
284;
285