Source file foldl.ml

(*
 * Generic transformers: plugins.
 * Copyright (C) 2016-2019
 *   Dmitrii Kosarev aka Kakadu
 * St.Petersburg State University, JetBrains Research
 *)

(** {i Foldl} plugin: fold all values in a type.

    Essentially is a stub that chains inherited attribute thorough all values
    in the value

    For type declaration [type ('a,'b,...) typ = ...] it will create a transformation
    function with type

    [('s -> 'a -> 's) ->
     ('s -> 'b -> 's) ->
     ... ->
     's -> ('a,'b,...) typ -> 's ]
*)

open Ppxlib
open Printf
open GTCommon
open HelpersBase

let trait_name = "foldl"

module Make (AstHelpers : GTHELPERS_sig.S) = struct
  open AstHelpers
  module P = Plugin.Make (AstHelpers)

  let trait_name = trait_name
  let make_dest_param_names ps = map_type_param_names ps ~f:(Printf.sprintf "%s_2")

  class g initial_args tdecls =
    object (self : 'self)
      inherit P.with_inherited_attr initial_args tdecls
      method trait_name = trait_name
      method syn_of_param ~loc s = Typ.var ~loc "syn"
      method inh_of_main ~loc tdecl = self#syn_of_main ~loc tdecl
      method syn_of_main ~loc ?in_class tdecl = self#syn_of_param ~loc "dummy"
      method inh_of_param ~loc tdecl _ = self#syn_of_param ~loc "dummy"

      method plugin_class_params ~loc typs ~typname =
        List.map typs ~f:Typ.from_caml
        @ [ Typ.var ~loc "syn"; Typ.var ~loc @@ Naming.make_extra_param typname ]

      (* new type of trasfomation function is 'syn -> old_type *)
      method! make_typ_of_class_argument
        : 'a.
          loc:loc
          -> type_declaration
          -> (Typ.t -> 'a -> 'a)
          -> string
          -> (('a -> 'a) -> 'a -> 'a)
          -> 'a
          -> 'a =
        fun ~loc tdecl chain name k ->
          let subj_t = Typ.var ~loc name in
          let syn_t = self#syn_of_param ~loc name in
          let inh_t = self#inh_of_param ~loc tdecl name in
          k @@ chain (Typ.arrow ~loc inh_t @@ Typ.arrow ~loc subj_t syn_t)

      method join_args ~loc do_typ ~init (xs : (string * core_type) list) =
        List.fold_left
          ~f:(fun acc (name, typ) ->
            Exp.app_list ~loc (do_typ typ) [ acc; Exp.sprintf ~loc "%s" name ])
          ~init
          xs

      method on_tuple_constr ~loc ~is_self_rec ~mutual_decls ~inhe tdecl constr_info args
          =
        self#join_args
          ~loc
          ~init:inhe
          (self#do_typ_gen ~loc ~is_self_rec ~mutual_decls tdecl)
          args

      method on_record_declaration ~loc ~is_self_rec ~mutual_decls tdecl labs =
        (* TODO: introduce fresh pattern names here *)
        let pat =
          Pat.record ~loc
          @@ List.map labs ~f:(fun l ->
               Lident l.pld_name.txt, Pat.var ~loc l.pld_name.txt)
        in
        let methname = sprintf "do_%s" tdecl.ptype_name.txt in
        [ Cf.method_concrete ~loc methname
          @@ Exp.fun_list ~loc [ Pat.sprintf ~loc "inh"; pat ]
          @@ self#join_args
               ~loc
               ~init:(Exp.ident ~loc "inh")
               (self#do_typ_gen ~loc ~is_self_rec ~mutual_decls tdecl)
               (List.map labs ~f:(fun l -> l.pld_name.txt, l.pld_type))
        ]

      method! on_record_constr
        ~loc
        ~is_self_rec
        ~mutual_decls
        ~inhe
        tdecl
        _info
        bindings
        labs =
        assert (List.length labs > 0);
        Exp.fun_list
          ~loc
          (List.map bindings ~f:(fun (s, _, _) -> Pat.sprintf ~loc "%s" s))
        @@ self#join_args
             ~loc
             ~init:inhe
             (self#do_typ_gen ~loc ~is_self_rec ~mutual_decls tdecl)
             (List.map bindings ~f:(fun (name, _, typ) -> name, typ))
    end

  let create = (new g :> P.plugin_constructor)
end

let register () = Expander.register_plugin trait_name (module Make : Plugin_intf.MAKE)
let () = register ()