Source file ppxlib_metaquot_lifters.ml

open Stdppx
open Ppxlib
open Ast_builder.Default

class expression_lifters loc =
  let loc = { loc with loc_ghost = true } in
  object
    inherit [expression] Ppxlib_traverse_builtins.lift

    method record flds =
      pexp_record ~loc
        (List.map flds ~f:(fun (lab, e) -> ({ loc; txt = Lident lab }, e)))
        None

    method constr id args =
      pexp_construct ~loc { loc; txt = Lident id }
        (match args with [] -> None | l -> Some (pexp_tuple ~loc l))

    method tuple l = pexp_tuple ~loc l
    method int i = eint ~loc i
    method int32 i = eint32 ~loc i
    method int64 i = eint64 ~loc i
    method nativeint i = enativeint ~loc i
    method float f = efloat ~loc (Float.to_string f)
    method string s = estring ~loc s
    method char c = echar ~loc c
    method bool b = ebool ~loc b

    method array : 'a. ('a -> expression) -> 'a array -> expression =
      fun f a -> pexp_array ~loc (List.map (Array.to_list a) ~f)

    method unit () = eunit ~loc
    method other : 'a. 'a -> expression = fun _ -> failwith "not supported"
  end

class pattern_lifters loc =
  let loc = { loc with loc_ghost = true } in
  object
    inherit [pattern] Ppxlib_traverse_builtins.lift

    method record flds =
      ppat_record ~loc
        (List.map flds ~f:(fun (lab, e) -> ({ loc; txt = Lident lab }, e)))
        Closed

    method constr id args =
      ppat_construct ~loc { loc; txt = Lident id }
        (match args with [] -> None | l -> Some (ppat_tuple ~loc l))

    method tuple l = ppat_tuple ~loc l
    method int i = pint ~loc i
    method int32 i = pint32 ~loc i
    method int64 i = pint64 ~loc i
    method nativeint i = pnativeint ~loc i
    method float f = pfloat ~loc (Float.to_string f)
    method string s = pstring ~loc s
    method char c = pchar ~loc c
    method bool b = pbool ~loc b

    method array : 'a. ('a -> pattern) -> 'a array -> pattern =
      fun f a -> ppat_array ~loc (List.map (Array.to_list a) ~f)

    method unit () = punit ~loc
    method other : 'a. 'a -> pattern = fun _ -> failwith "not supported"
  end