i18n_ppx_rewriter.ml

(*
 * Copyright (C) 2015 BeSport, Julien Sagot
 *
 * 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)

open! Ppxlib

let default_module_name = ref ""
let module_prefix = ref ""
let module_suffix = ref ""

let mk_ident i =
  if !default_module_name = "" then invalid_arg "Missing default module name";
  let module_name, safe_ident =
    match i with
    (* CASE 1: [%i18n ident ... ] *)
    | Lident _ -> !default_module_name, i
    (* CASE 2: [%i18n S.ident ... ] *)
    | Ldot (Lident "S", _) -> !default_module_name, i
    (* CASE 3: [%i18n OtherMod.ident ...] *)
    | Ldot (Lident module_name, s) ->
     !module_prefix ^ module_name ^ !module_suffix, Lident s
    (* CASE 4 : [%i18n OtherMod.S.ident ...] *)
    | Ldot (Ldot (Lident module_name, "S"), s) ->
     !module_prefix ^ module_name ^ !module_suffix, Ldot (Lident "S", s)
    (* CASE X : [%i18n OtherModA.OtherModB.ident ...]. Illegal. *)
    | i -> let err_msg =
             Format.asprintf "%s is not a valid i18n expression"
               (Longident.name i)
      in failwith err_msg
  in
  let rec prefix i =
    match i with
    | Lident id ->
       Ldot (Ldot (Lident module_name, "Tr"), id)
    | Ldot (i, nm) ->
       Ldot (prefix i, nm)
    | Lapply _ ->
       let err_msg =
             Format.asprintf "%s is not a valid i18n expression"
               (Longident.name i)
      in failwith err_msg
  in
  prefix safe_ident

let unit loc =
  let open Ast_builder.Default in
  (Nolabel, pexp_construct ~loc (Located.mk ~loc (Lident "()")) None)

let lang_args = function
  | ((Labelled("?lang"), _) as lang) :: args
  | ((Labelled("~lang"), _) as lang) :: args -> ([ lang ], args)
  | x -> ([], x)

let ident loc id =
  let open Ast_builder.Default in
  pexp_ident ~loc (Located.mk ~loc (mk_ident id))

let apply loc id args =
  let (lang, args) = lang_args args in
  let open Ast_builder.Default in
  pexp_apply ~loc (ident loc id) (lang @ [unit loc] @ args @ [unit loc])

let () =
  List.iter
    (fun (key, spec, doc) -> Ppxlib.Driver.add_arg key spec ~doc)
    ["--prefix", Arg.Set_string module_prefix,
     "PREFIX The prefix added to module names"
    ;"--suffix", Arg.Set_string module_suffix,
     "SUFFIX The suffix added to module names"
    ;"--default-module", Arg.Set_string default_module_name,
     "MODULE Name of the default module"]

let expand ~loc:loc0 ~path:_ expr =
  Ppxlib.Ast_pattern.
  (parse (pexp_ident __ |> map1 ~f:(fun id -> apply loc0 id [])
          ||| (pexp_apply (pexp_ident __) (many __)  |> map2 ~f:(apply loc0))))
    loc0 expr (fun x -> x)

let extension =
  Ppxlib.Extension.declare
    "i18n"
    Ppxlib.Extension.Context.expression
    Ppxlib.Ast_pattern.(single_expr_payload __)
    expand

let rule = Ppxlib.Context_free.Rule.extension extension

let () =
  Ppxlib.Driver.register_transformation ~rules:[rule] "i18n"