ocaml-gettext/0009-Convert-from-camlp4-to-ppx-for-translatable-string-e.patch

From 739e3a900993299e7e8b90af3da565417eb84412 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Fri, 12 Jul 2019 16:02:16 +0100
Subject: [PATCH 09/11] Convert from camlp4 to ppx for translatable string
 extraction.

---
 aclocal.m4                     |   6 +-
 configure.in                   |   3 -
 libgettext-ocaml/Makefile      |  17 ---
 libgettext-ocaml/pr_gettext.ml | 218 -------------------------------
 ocaml-gettext/Makefile         |  11 +-
 ocaml-gettext/OCamlGettext.ml  |   2 +-
 ocaml-gettext/xgettext.ml      | 228 +++++++++++++++++++++++++++++++++
 test/test.ml                   |   4 +-
 8 files changed, 234 insertions(+), 255 deletions(-)
 delete mode 100644 libgettext-ocaml/pr_gettext.ml
 create mode 100644 ocaml-gettext/xgettext.ml

diff --git a/aclocal.m4 b/aclocal.m4
index 72a27da..2a1110f 100644
--- a/aclocal.m4
+++ b/aclocal.m4
@@ -204,7 +204,7 @@ else
 fi
 ])
 
-# AC_CHECK_[CAMLP4,CAMLIDL,OCAMLMKLIB,MKCAMLP4] ([ACTION-IF-FOUND],[ACTION-IF-NOT-FOUND])
+# AC_CHECK_[CAMLIDL,OCAMLMKLIB] ([ACTION-IF-FOUND],[ACTION-IF-NOT-FOUND])
 #---------------------------------------------------------
 # Subst the corresponding var
 AC_DEFUN([AC_CHECK_STAR],
@@ -219,12 +219,8 @@ else
 fi
 AC_SUBST($1)
 ])
-AC_DEFUN([AC_CHECK_CAMLP4],     [AC_CHECK_STAR(CAMLP4,camlp4,$1,$2)])
-AC_DEFUN([AC_CHECK_CAMLP4OF],   [AC_CHECK_STAR(CAMLP4OF,camlp4of,$1,$2)])
-AC_DEFUN([AC_CHECK_CAMLP4O],    [AC_CHECK_STAR(CAMLP4O,camlp4o,$1,$2)])
 AC_DEFUN([AC_CHECK_CAMLIDL],    [AC_CHECK_STAR(CAMLIDL,camlidl,$1,$2)])
 AC_DEFUN([AC_CHECK_OCAMLMKLIB], [AC_CHECK_STAR(OCAMLMKLIB,ocamlmklib,$1,$2)])
-AC_DEFUN([AC_CHECK_MKCAMLP4],   [AC_CHECK_STAR(MKCAMLP4,mkcamlp4,$1,$2)])
 AC_DEFUN([AC_CHECK_OCAMLDOC],   [AC_CHECK_STAR(OCAMLDOC,ocamldoc,$1,$2)])
 AC_DEFUN([AC_CHECK_XSLTPROC],   [AC_CHECK_STAR(XSLTPROC,xsltproc,$1,$2)])
 AC_DEFUN([AC_CHECK_XMLLINT],    [AC_CHECK_STAR(XMLLINT,xmllint,$1,$2)])
diff --git a/configure.in b/configure.in
index 9840d2b..3ef4c8d 100644
--- a/configure.in
+++ b/configure.in
@@ -85,9 +85,6 @@ AC_CHECK_OCAMLOPT([],[AC_MSG_WARN(Cannot find ocamlopt, byte compilation only)])
 AC_CHECK_OCAMLLEX([],[AC_MSG_ERROR(Cannot find ocamllex.)])
 AC_CHECK_OCAMLYACC([],[AC_MSG_ERROR(Cannot find ocamlyacc.)])
 AC_CHECK_OCAMLFIND([],[AC_MSG_ERROR(Cannot find ocamlfind.)])
-AC_CHECK_CAMLP4([],[AC_MSG_ERROR(Cannot find camlp4.)])
-AC_CHECK_CAMLP4O([],[AC_MSG_ERROR(Cannot find camlp4o.)])
-AC_CHECK_CAMLP4OF([],[AC_MSG_ERROR(Cannot find camlp4of.)])
 AC_CHECK_OCAMLMKLIB([],[AC_MSG_ERROR(Cannot find ocamlmklib.)])
 
 if test "x$BUILD_DOC" = "xyes"; then
diff --git a/libgettext-ocaml/Makefile b/libgettext-ocaml/Makefile
index 1a155c1..e64e0a1 100644
--- a/libgettext-ocaml/Makefile
+++ b/libgettext-ocaml/Makefile
@@ -161,22 +161,5 @@ clean::
 	-$(RM) gettextCompile.mli
 	-$(RM) gettextMo.mli
 
-########################
-# Pa_gettext extension #
-########################
-
-INSTALLIB +=        \
- pr_gettext.cmo    
-
-pr_gettext.cmo: pr_gettext.ml
-	ocamlc \
-	  -I +camlp4 \
-	  -I $(shell ocamlc -where)/camlp4/Camlp4Parsers \
-	  -pp camlp4of \
-	  camlp4lib.cma \
-	  gettextBase.cma \
-	  gettextExtension.cma \
-	  -c $< -o $@
-
 include ../ConfMakefile
 include ../TopMakefile
diff --git a/libgettext-ocaml/pr_gettext.ml b/libgettext-ocaml/pr_gettext.ml
deleted file mode 100644
index 47d93e5..0000000
--- a/libgettext-ocaml/pr_gettext.ml
+++ /dev/null
@@ -1,218 +0,0 @@
-(**************************************************************************)
-(*  ocaml-gettext: a library to translate messages                        *)
-(*                                                                        *)
-(*  Copyright (C) 2003-2008 Sylvain Le Gall <sylvain@le-gall.net>         *)
-(*                                                                        *)
-(*  This library 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; either          *)
-(*  version 2.1 of the License, or (at your option) any later version;    *)
-(*  with the OCaml static compilation exception.                          *)
-(*                                                                        *)
-(*  This library 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 library; if not, write to the Free Software   *)
-(*  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307   *)
-(*  USA                                                                   *)
-(**************************************************************************)
-
-(** Camlp4 dumper to extract strings.
-    @author Sylvain Le Gall
-    @author Richard W.M. Jones (translation to OCaml 3.10.X new camlp4)
-  *)
-
-(* Extract the string which should be used for a gettext translation. Output a
-   po_content list through the function Marshal.to_channel
-   Functions that are looked for :
-Functions     Arg 1      Arg 2      Arg 3      Arg 4      Arg 5      Arg 6   ...
-s_            singular
-f_            singular
-sn_           singular   plural     _
-fn_           singular   plural     _
-gettext       _          singular
-fgettext      _          singular
-dgettext      _          domain     singular
-fdgettext     _          domain     singular
-dcgettext     _          domain     singular   _
-fdcgettext    _          domain     singular   _
-ngettext      _          singular   plural     _        
-fngettext     _          singular   plural     _          
-dngettext     _          domain     singular   plural     _
-fdngettext    _          domain     singular   plural     _
-dcngettext    _          domain     singular   plural     _          _   
-fdcngettext   _          domain     singular   plural     _          _
-
-
-All this function name should also be matched when they are called using a
-module.
-                                      
-*)
-
-open Format
-open GettextTypes
-open GettextPo
-
-let default_textdomain = ref None
-
-module Id = struct
-  (* name is printed with the -loaded-modules switch *) 
-  let name = "pr_gettext" 
-  (* cvs id's seem to be the preferred version string *) 
-  let version = "$Id$" 
-end 
-
-module Make (Syntax : Camlp4.Sig.Camlp4Syntax)
-  : Camlp4.Sig.Printer(Syntax.Ast).S =
-struct
-  module Loc = Syntax.Loc
-  module Ast = Syntax.Ast
-
-  type t = 
-      {
-        po_content:   po_content;
-        translated:   SetString.t;
-      }
-
-  let string_of_ocaml_string str =
-    Scanf.sscanf 
-      (Printf.sprintf "\"%s\"" str)
-      "%S"
-      (fun s -> s)
-
-
-  let add_translation t loc ocaml_singular plural_opt domain =
-    let filepos = 
-      Loc.file_name loc, Loc.start_line loc 
-    in
-    let singular = 
-      string_of_ocaml_string ocaml_singular
-    in
-    let translated = 
-      SetString.add ocaml_singular t.translated
-    in
-    let translated, translation =
-      match plural_opt with 
-        | Some ocaml_plural -> 
-            let plural = 
-              string_of_ocaml_string ocaml_plural
-            in
-              SetString.add ocaml_plural translated,
-              {
-                po_comment_special = [];
-                po_comment_filepos = [filepos];
-                po_comment_translation = PoPlural([singular],[plural],[[""];[""]]);
-              }
-        | None -> 
-            translated,
-            {
-              po_comment_special = [];
-              po_comment_filepos = [filepos];
-              po_comment_translation = PoSingular([singular],[""]);
-            }
-    in
-    let po_content = 
-      match domain, !default_textdomain with 
-        | Some domain, _ -> 
-            add_po_translation_domain domain t.po_content translation
-        | None, Some domain ->
-            add_po_translation_domain domain t.po_content translation
-        | None, None ->
-            add_po_translation_no_domain t.po_content translation
-    in
-      {t with 
-           po_content = po_content;
-           translated = translated}
-
-  let output_translations ?output_file t = 
-    let fd = 
-      match output_file with
-        | Some f -> open_out f
-        | None -> stdout
-    in
-      Marshal.to_channel fd t.po_content []
-
-  (* Check if the given node belong to the given functions *)
-  let is_like e functions = 
-    let rec function_name e =
-      match e with 
-        | <:ident<$_$.$id:e$>> ->
-          function_name e
-        | <:ident<$lid:s$>> ->
-          s
-        | _ ->
-            raise Not_found
-    in
-      try
-        List.mem (function_name e) functions
-      with Not_found ->
-        false
-
-  class visitor = object
-    inherit Ast.fold as super
-
-    val t = 
-      {
-        po_content   = empty_po;
-        translated   = SetString.empty;
-      }
-
-    method t = t
-
-    method expr = function
-    | <:expr@loc< $id:e$ $str:singular$ >> when 
-        is_like e ["s_"; "f_"] ->
-      (* Add a singular / default domain string *)
-      {< t = add_translation t loc singular None None >}
-
-    | <:expr@loc< $id:e$ $str:singular$ $str:plural$ >> when 
-        is_like e ["sn_"; "fn_"] ->
-      (* Add a plural / default domain string *)
-      {< t = add_translation t loc singular (Some plural) None >}
-
-    | <:expr@loc< $id:e$ $expr$ $str:singular$ >> when 
-        is_like e ["gettext"; "fgettext"] ->
-      (* Add a singular / default domain string *)
-      {< t = add_translation t loc singular None None >}
-
-    | <:expr@loc< $id:e$ $expr$ $str:domain$ $str:singular$ >> when 
-        is_like e ["dgettext"; "fdgettext"; "dcgettext"; "fdcgettext"] ->
-      (* Add a singular / defined domain string *)
-      {< t = add_translation t loc singular None (Some domain) >}
-
-    | <:expr@loc< $id:e$ $expr$ $str:singular$ $str:plural$ >> when 
-        is_like e ["ngettext"; "fngettext"] ->
-      (* Add a plural / default domain string *)
-      {< t = add_translation t loc singular (Some plural) None >}
-
-    | <:expr@loc< $id:e$ $expr$ $str:domain$ $str:singular$ $str:plural$ >> when
-        is_like e ["dngettext"; "fdngettext"; "dcngettext"; "fdcngettext"] ->
-      (* Add a plural / defined domain string *)
-      {< t = add_translation t loc singular (Some plural) (Some domain) >}
-
-    | e -> super#expr e
-
-  end
-
-  (* Called on *.mli files, but cannot contain translateable strings. *)
-  let print_interf ?input_file ?output_file _ = ()
-
-  (* Called on *.ml files. *)
-  let print_implem ?input_file ?output_file ast =
-    let visitor = (new visitor)#str_item in
-    let t = (visitor ast)#t in
-    output_translations ?output_file t
-end
-
-(* Register the new printer. *)
-module M = Camlp4.Register.OCamlPrinter(Id)(Make) ;;
-
-(* XXX How to do this?
-Pcaml.add_option "-default-textdomain" 
-  (Arg.String ( fun textdomain -> default_textdomain := Some textdomain ) )
-  "<textdomain> Defines the default textdomain"
-;;
-*)
diff --git a/ocaml-gettext/Makefile b/ocaml-gettext/Makefile
index d5f37fa..0c1199e 100644
--- a/ocaml-gettext/Makefile
+++ b/ocaml-gettext/Makefile
@@ -61,14 +61,9 @@ install: ocaml-xgettext-install
 
 uninstall: ocaml-xgettext-uninstall
 
-ocaml-xgettext: $(BUILDBIN)
-	$(OCAMLC)                                                            \
-           -I +camlp4 dynlink.cma camlp4lib.cma                              \
-          `$(OCAMLFIND) query -r -predicates byte gettext.extract -i-format` \
-          `$(OCAMLFIND) query -r -predicates byte gettext.extract -a-format` \
-          `$(OCAMLFIND) query -r -predicates byte gettext.extract -o-format` \
-           Camlp4Bin.cmo                                                     \
-          -o $@
+ocaml-xgettext: xgettext.ml
+	$(OCAMLC) -I ../libgettext-ocaml -I +compiler-libs \
+	    ocamlcommon.cma gettextBase.cma gettextExtension.cma $< -o $@
 	$(INSTALL_SCRIPT) -t $(BUILDBIN) $@
 
 ocaml-xgettext-install:
diff --git a/ocaml-gettext/OCamlGettext.ml b/ocaml-gettext/OCamlGettext.ml
index 837057e..d643a9b 100644
--- a/ocaml-gettext/OCamlGettext.ml
+++ b/ocaml-gettext/OCamlGettext.ml
@@ -283,7 +283,7 @@ let () =
     {
       action_option               = None;
       extract_command             = "ocaml-xgettext";
-      extract_default_option      = "-I +camlp4 pa_o.cmo";
+      extract_default_option      = "";
       extract_filename_options    = [];
       extract_pot                 = "messages.pot";
       compile_output_file_option  = None;
diff --git a/ocaml-gettext/xgettext.ml b/ocaml-gettext/xgettext.ml
new file mode 100644
index 0000000..76232d8
--- /dev/null
+++ b/ocaml-gettext/xgettext.ml
@@ -0,0 +1,228 @@
+(**************************************************************************)
+(*  ocaml-gettext: a library to translate messages                        *)
+(*                                                                        *)
+(*  Copyright (C) 2003-2008 Sylvain Le Gall <sylvain@le-gall.net>         *)
+(*                                                                        *)
+(*  This library 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; either          *)
+(*  version 2.1 of the License, or (at your option) any later version;    *)
+(*  with the OCaml static compilation exception.                          *)
+(*                                                                        *)
+(*  This library 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 library; if not, write to the Free Software   *)
+(*  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307   *)
+(*  USA                                                                   *)
+(**************************************************************************)
+
+(** PPX dumper to extract strings.
+    @author Richard W.M. Jones
+    @author Sylvain Le Gall
+  *)
+
+(* Extract the string which should be used for a gettext translation. Output a
+   po_content list through the function Marshal.to_channel
+   Functions that are looked for :
+
+Functions     Arg 1      Arg 2      Arg 3      Arg 4      Arg 5      Arg 6   ...
+s_            singular
+f_            singular
+sn_           singular   plural     _
+fn_           singular   plural     _
+gettext       _          singular
+fgettext      _          singular
+dgettext      _          domain     singular
+fdgettext     _          domain     singular
+dcgettext     _          domain     singular   _
+fdcgettext    _          domain     singular   _
+ngettext      _          singular   plural     _
+fngettext     _          singular   plural     _
+dngettext     _          domain     singular   plural     _
+fdngettext    _          domain     singular   plural     _
+dcngettext    _          domain     singular   plural     _          _
+fdcngettext   _          domain     singular   plural     _          _
+
+All this function name should also be matched when they are called using a
+module.
+
+*)
+
+open GettextTypes
+open GettextPo
+open Parsetree
+open Longident
+open Location
+
+type t = {
+  po_content:   po_content;
+  translated:   SetString.t;
+}
+
+let string_of_ocaml_string str =
+  Scanf.sscanf
+    (Printf.sprintf "\"%s\"" str)
+    "%S"
+    (fun s -> s)
+
+let translations = ref { po_content = empty_po; translated = SetString.empty }
+
+let default_textdomain = ref None
+
+let current_file = ref ""
+
+let add_translation loc ocaml_singular plural_opt domain =
+  let t = !translations in
+
+  let filepos =
+    let start = loc.Location.loc_start in
+    let fname =
+      match start.Lexing.pos_fname with "" -> !current_file
+                                      | fname -> fname in
+    fname, start.Lexing.pos_lnum
+  in
+  let singular =
+    string_of_ocaml_string ocaml_singular
+  in
+  let translated =
+    SetString.add ocaml_singular t.translated
+  in
+  let translated, translation =
+    match plural_opt with
+    | Some ocaml_plural ->
+       let plural =
+         string_of_ocaml_string ocaml_plural
+       in
+       SetString.add ocaml_plural translated,
+       {
+         po_comment_special = [];
+         po_comment_filepos = [filepos];
+         po_comment_translation = PoPlural([singular],[plural],[[""];[""]]);
+       }
+    | None ->
+       translated,
+       {
+         po_comment_special = [];
+         po_comment_filepos = [filepos];
+         po_comment_translation = PoSingular([singular],[""]);
+       }
+  in
+  let po_content =
+    match domain, !default_textdomain with
+    | Some domain, _ ->
+       add_po_translation_domain domain t.po_content translation
+    | None, Some domain ->
+       add_po_translation_domain domain t.po_content translation
+    | None, None ->
+       add_po_translation_no_domain t.po_content translation
+  in
+
+  translations := { po_content; translated }
+
+let output_translations ?output_file t =
+  let fd =
+    match output_file with
+    | Some f -> open_out f
+    | None -> stdout
+  in
+  Marshal.to_channel fd t.po_content []
+
+let rec is_like lid = function
+  | [] -> false
+  | func :: functions ->
+     match lid with
+     | Lident f
+     | Ldot (_, f) when f = func -> true
+     | _ -> is_like lid functions
+
+let visit_expr (iterator : Ast_iterator.iterator) expr =
+  let loc = expr.pexp_loc in
+  match expr.pexp_desc with
+  | Pexp_apply (
+      { pexp_desc = Pexp_ident ({ Asttypes.txt = lid })},
+      (Asttypes.Nolabel,
+       { pexp_desc = Pexp_constant (Pconst_string (singular, _)) }) ::
+       _)
+      when is_like lid ["s_"; "f_"] ->
+     (* Add a singular / default domain string *)
+     add_translation loc singular None None
+
+  | Pexp_apply (
+      { pexp_desc = Pexp_ident ({ Asttypes.txt = lid })},
+      (Asttypes.Nolabel,
+       { pexp_desc = Pexp_constant (Pconst_string (singular, _)) }) ::
+      (Asttypes.Nolabel,
+       { pexp_desc = Pexp_constant (Pconst_string (plural, _)) }) ::
+       _)
+       when is_like lid ["sn_"; "fn_"] ->
+      (* Add a plural / default domain string *)
+     add_translation loc singular (Some plural) None
+
+  | Pexp_apply (
+      { pexp_desc = Pexp_ident ({ Asttypes.txt = lid })},
+      (_ ::
+       (Asttypes.Nolabel,
+        { pexp_desc = Pexp_constant (Pconst_string (singular, _)) }) ::
+       _))
+       when is_like lid ["gettext"; "fgettext"] ->
+     (* Add a singular / default domain string *)
+     add_translation loc singular None None
+
+  | Pexp_apply (
+      { pexp_desc = Pexp_ident ({ Asttypes.txt = lid })},
+      (_ ::
+       (Asttypes.Nolabel,
+        { pexp_desc = Pexp_constant (Pconst_string (domain, _)) }) ::
+       (Asttypes.Nolabel,
+        { pexp_desc = Pexp_constant (Pconst_string (singular, _)) }) ::
+       _))
+       when is_like lid ["dgettext"; "fdgettext"; "dcgettext"; "fdcgettext"] ->
+     (* Add a singular / defined domain string *)
+     add_translation loc singular None (Some domain)
+
+  | Pexp_apply (
+      { pexp_desc = Pexp_ident ({ Asttypes.txt = lid })},
+      (_ ::
+       (Asttypes.Nolabel,
+        { pexp_desc = Pexp_constant (Pconst_string (singular, _)) }) ::
+       (Asttypes.Nolabel,
+        { pexp_desc = Pexp_constant (Pconst_string (plural, _)) }) ::
+       _))
+       when is_like lid ["ngettext"; "fngettext"] ->
+     (* Add a plural / default domain string *)
+     add_translation loc singular (Some plural) None
+
+  | Pexp_apply (
+      { pexp_desc = Pexp_ident ({ Asttypes.txt = lid })},
+      (_ ::
+       (Asttypes.Nolabel,
+        { pexp_desc = Pexp_constant (Pconst_string (domain, _)) }) ::
+       (Asttypes.Nolabel,
+        { pexp_desc = Pexp_constant (Pconst_string (singular, _)) }) ::
+       (Asttypes.Nolabel,
+        { pexp_desc = Pexp_constant (Pconst_string (plural, _)) }) ::
+       _))
+       when is_like lid ["dngettext"; "fdngettext"; "dcngettext"; "fdcngettext"] ->
+     (* Add a plural / defined domain string *)
+     add_translation loc singular (Some plural) (Some domain)
+
+  | _ ->
+     Ast_iterator.default_iterator.expr iterator expr
+
+let ast_iterator =
+  { Ast_iterator.default_iterator with expr = visit_expr }
+
+let go fn =
+  current_file := fn;
+  let lexbuf = Lexing.from_channel (open_in fn) in
+  let structure = Parse.implementation lexbuf in
+  ast_iterator.Ast_iterator.structure ast_iterator structure
+
+let () =
+  (* XXX Add -default-textdomain option which sets default_textdomain. *)
+  Arg.parse [] go "";
+  output_translations !translations
diff --git a/test/test.ml b/test/test.ml
index bf59889..331c677 100644
--- a/test/test.ml
+++ b/test/test.ml
@@ -353,9 +353,7 @@ let compatibility_test tests =
 (*******************************************)
 
 let extract_test tests = 
-  let default_options = 
-    "-I +camlp4 pa_o.cmo"
-  in
+  let default_options = "" in
   let filename_options = 
     MapString.empty
   in
-- 
2.22.0