X-Git-Url: http://git.hcoop.net/bpt/coccinelle.git/blobdiff_plain/17ba07880e1838028b4516ba7a2db2147b3aa1c9..feec80c30d140c69f5d894bd09b6071247d0fbaa:/bundles/sexplib/sexplib-7.0.5/syntax/pa_sexp_conv.ml diff --git a/bundles/sexplib/sexplib-7.0.5/syntax/pa_sexp_conv.ml b/bundles/sexplib/sexplib-7.0.5/syntax/pa_sexp_conv.ml new file mode 100644 index 0000000..ba066db --- /dev/null +++ b/bundles/sexplib/sexplib-7.0.5/syntax/pa_sexp_conv.ml @@ -0,0 +1,1383 @@ +(****************************************************************************** + * Sexplib * + * * + * Copyright (C) 2005- Jane Street Holding, LLC * + * Contact: opensource@janestreet.com * + * WWW: http://www.janestreet.com/ocaml * + * Author: Markus Mottl * + * * + * This file is derived from file "pa_tywith.ml" of version 0.45 of the * + * library "Tywith". * + * * + * Tywith is Copyright (C) 2004, 2005 by * + * * + * Martin Sandin * + * * + * * + * 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 of the License, or (at your option) any later version. * + * * + * 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 * + * * + ******************************************************************************) + +(* Pa_sexp_conv: Preprocessing Module for Automated S-expression Conversions *) + +open StdLabels +open MoreLabels + +open Printf + +open Camlp4 +open PreCast + +module Gen = Pa_type_conv.Gen + +(* Utility functions *) + +let mk_rev_bindings loc fps = + let coll (i, bindings, patts, vars) fp = + let name = "v" ^ string_of_int i in + let var_expr = <:expr@loc< $lid:name$ >> in + let expr = + match fp with + | `Fun fun_expr -> <:expr@loc< $fun_expr$ $var_expr$ >> + | `Match matchings -> <:expr@loc< match $var_expr$ with [ $matchings$ ] >> + in + let patt = <:patt@loc< $lid:name$ >> in + let bindings = <:binding@loc< $patt$ = $expr$ and $bindings$ >> in + i - 1, bindings, patt :: patts, var_expr :: vars + in + let n = List.length fps in + let _, bindings, patts, expr = + List.fold_left ~f:coll ~init:(n, Ast.BiNil loc, [], []) fps + in + bindings, patts, expr + +let mk_bindings loc fps = mk_rev_bindings loc (List.rev fps) + +let unroll_cnv_fp loc var = function + | `Fun fun_expr -> <:expr@loc< $fun_expr$ $var$ >> + | `Match matchings -> <:expr@loc< match $var$ with [ $matchings$ ] >> + +let unroll_fun_matches loc fp1 fp2 = + match fp1, fp2 with + | `Fun fun_expr1, `Fun fun_expr2 -> + <:expr@loc< $fun_expr1$ $fun_expr2$ >> + | `Fun fun_expr, `Match matching -> + <:expr@loc< $fun_expr$ (fun [ $matching$ ]) >> + | _ -> assert false (* impossible *) + +let rec sig_of_tds cnv = function + | Ast.TyDcl (loc, type_name, tps, rhs, cl) -> cnv loc type_name tps rhs cl + | Ast.TyAnd (loc, tp1, tp2) -> + <:sig_item@loc< $sig_of_tds cnv tp1$; $sig_of_tds cnv tp2$ >> + | _ -> assert false (* impossible *) + + +(* Generators for S-expressions *) + +(* Generates the signature for type conversion to S-expressions *) +module Sig_generate_sexp_of = struct + + let rec sig_of_td__loop acc = function + | [] -> + let loc = Ast.loc_of_ctyp acc in + <:ctyp@loc< $acc$ -> Sexplib.Sexp.t >> + | tp :: tps -> + let tp = Gen.drop_variance_annotations tp in + let loc = Ast.loc_of_ctyp tp in + let sexp_of = sig_of_td__loop <:ctyp@loc< $acc$ $tp$ >> tps in + <:ctyp@loc< ( $tp$ -> Sexplib.Sexp.t ) -> $sexp_of$ >> + + let sig_of_td loc type_name tps _rhs _cl = + let sexp_of = sig_of_td__loop <:ctyp@loc< $lid:type_name$ >> tps in + <:sig_item@loc< value $lid: "sexp_of_" ^ type_name$ : $sexp_of$ >> + + let mk_sig tds = <:sig_item< $sig_of_tds sig_of_td tds$ >> + + let () = Pa_type_conv.add_sig_generator "sexp_of" mk_sig + + let mk_sig_exn = function + | <:ctyp@loc< $uid:_$ >> | <:ctyp@loc< $uid:_$ of $_$ >> -> + <:sig_item@loc< >> + | tp -> Gen.error tp ~fn:"mk_sig_exn" ~msg:"unknown type" + + let () = Pa_type_conv.add_sig_generator ~is_exn:true "sexp" mk_sig_exn +end + + +(* Generates the signature for type conversion from S-expressions *) +module Sig_generate_of_sexp = struct + + let rec is_polymorphic_variant = function + | <:ctyp< private $tp$ >> -> is_polymorphic_variant tp + | <:ctyp< ( $tup:_$ ) >> + | <:ctyp< $_$ -> $_$ >> + | <:ctyp< { $_$ } >> + | <:ctyp< [ $_$ ] >> -> `Surely_not + | <:ctyp< [< $_$ ] >> | <:ctyp< [> $_$ ] >> + | <:ctyp< [= $_$ ] >> -> `Definitely + | <:ctyp< '$_$ >> + | <:ctyp< $_$ $_$ >> + | <:ctyp< $id:_$ >> + | <:ctyp< >> -> `Maybe + | <:ctyp< $tp1$ == $tp2$ >> -> + begin match is_polymorphic_variant tp1 with + | (`Surely_not | `Definitely) as res -> res + | `Maybe -> is_polymorphic_variant tp2 end + | tp -> Gen.unknown_type tp "Sig_generate_of_sexp.is_polymorphic_variant" + + let rec sig_of_td__loop acc = function + | [] -> + let loc = Ast.loc_of_ctyp acc in + <:ctyp@loc< Sexplib.Sexp.t -> $acc$ >> + | tp :: tps -> + let tp = Gen.drop_variance_annotations tp in + let loc = Ast.loc_of_ctyp tp in + let of_sexp = sig_of_td__loop <:ctyp@loc< $acc$ $tp$ >> tps in + <:ctyp@loc< ( Sexplib.Sexp.t -> $tp$ ) -> $of_sexp$ >> + + let sig_of_td with_poly loc type_name tps rhs _cl = + let of_sexp = sig_of_td__loop <:ctyp@loc< $lid:type_name$ >> tps in + let of_sexp_item = + <:sig_item@loc< value $lid: type_name ^ "_of_sexp"$ : $of_sexp$; >> + in + match with_poly, is_polymorphic_variant rhs with + | true, `Surely_not -> + Gen.error rhs ~fn:"Sig_generate_of_sexp.sig_of_td" + ~msg:"sexp_poly annotation \ + but type is surely not a polymorphic variant" + | false, (`Surely_not | `Maybe) -> of_sexp_item + | (true | false), `Definitely | true, `Maybe -> + <:sig_item@loc< + $of_sexp_item$; + value $lid: type_name ^ "_of_sexp__"$ : $of_sexp$; + >> + + let mk_sig with_poly tds = + <:sig_item< $sig_of_tds (sig_of_td with_poly) tds$ >> + + let () = Pa_type_conv.add_sig_generator "of_sexp" (mk_sig false) + let () = Pa_type_conv.add_sig_generator "of_sexp_poly" (mk_sig true) +end + + +(* Generates the signature for type conversion to S-expressions *) +module Sig_generate = struct + let () = + Pa_type_conv.add_sig_generator "sexp" (fun tds -> + let loc = Ast.loc_of_ctyp tds in + <:sig_item@loc< + $Sig_generate_sexp_of.mk_sig tds$; + $Sig_generate_of_sexp.mk_sig false tds$ + >>) + + let () = + Pa_type_conv.add_sig_generator "sexp_poly" (fun tds -> + let loc = Ast.loc_of_ctyp tds in + <:sig_item@loc< + $Sig_generate_sexp_of.mk_sig tds$; + $Sig_generate_of_sexp.mk_sig true tds$ + >>) +end + + +(* Generator for converters of OCaml-values to S-expressions *) +module Generate_sexp_of = struct + let mk_abst_call loc tn rev_path = + <:expr@loc< + $id:Gen.ident_of_rev_path loc (("sexp_of_" ^ tn) :: rev_path)$ + >> + + (* Conversion of type paths *) + let sexp_of_path_fun loc id = + match Gen.get_rev_id_path id [] with + | tn :: rev_path -> mk_abst_call loc tn rev_path + | [] -> assert false (* impossible *) + + (* Conversion of types *) + let rec sexp_of_type = function + | <:ctyp@loc< sexp_opaque $_$ >> -> + `Fun <:expr@loc< Sexplib.Conv.sexp_of_opaque >> + | <:ctyp@loc< $tp1$ $tp2$ >> -> `Fun (sexp_of_appl_fun loc tp1 tp2) + | <:ctyp< ( $tup:tp$ ) >> -> sexp_of_tuple tp + | <:ctyp@loc< '$parm$ >> -> `Fun <:expr@loc< $lid:"_of_" ^ parm$ >> + | <:ctyp@loc< $id:id$ >> -> `Fun (sexp_of_path_fun loc id) + | <:ctyp@loc< $_$ -> $_$ >> as arrow -> + `Fun <:expr@loc< fun (_f : $arrow$) -> + Sexplib.Conv.sexp_of_fun Pervasives.ignore >> + | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> + | <:ctyp< [= $row_fields$ ] >> -> sexp_of_variant row_fields + | <:ctyp< ! $parms$ . $poly_tp$ >> -> sexp_of_poly parms poly_tp + | tp -> Gen.unknown_type tp "sexp_of_type" + + (* Conversion of polymorphic types *) + and sexp_of_appl_fun loc tp1 tp2 = + match sexp_of_type tp1, sexp_of_type tp2 with + | `Fun fun_expr1, `Fun fun_expr2 -> <:expr@loc< $fun_expr1$ $fun_expr2$ >> + | `Fun fun_expr, `Match matching -> + <:expr@loc< $fun_expr$ (fun [ $matching$ ]) >> + | _ -> assert false (* impossible *) + + + (* Conversion of tuples *) + and sexp_of_tuple tp = + let loc = Ast.loc_of_ctyp tp in + let fps = List.map ~f:sexp_of_type (Ast.list_of_ctyp tp []) in + let bindings, patts, vars = mk_bindings loc fps in + let in_expr = <:expr@loc< Sexplib.Sexp.List $Gen.mk_expr_lst loc vars$ >> in + let expr = <:expr@loc< let $bindings$ in $in_expr$ >> in + `Match <:match_case@loc< ( $tup:Ast.paCom_of_list patts$ ) -> $expr$ >> + + + (* Conversion of variant types *) + + and mk_cnv_expr tp = + let loc = Ast.loc_of_ctyp tp in + match sexp_of_type tp with + | `Fun fun_expr -> <:expr@loc< $fun_expr$ >> + | `Match matchings -> <:expr@loc< fun [ $matchings$ ] >> + + and sexp_of_variant row_fields = + let rec loop = function + | <:ctyp@loc< $tp1$ | $tp2$ >> -> + <:match_case@loc< $loop tp1$ | $loop tp2$ >> + | <:ctyp@loc< `$cnstr$ >> -> + <:match_case@loc< `$cnstr$ -> Sexplib.Sexp.Atom $str:cnstr$ >> + | <:ctyp@loc< `$cnstr$ of sexp_list $tp$>> -> + let cnv_expr = + match sexp_of_type tp with + | `Fun fun_expr -> <:expr@loc< $fun_expr$ >> + | `Match matchings -> + <:expr@loc< fun el -> match el with [ $matchings$ ] >> + in + <:match_case@loc< + `$cnstr$ l -> + Sexplib.Sexp.List + [ Sexplib.Sexp.Atom $str:cnstr$ :: + Sexplib.Conv.list_map $cnv_expr$ l] + >> + | <:ctyp@loc< `$cnstr$ of $tps$ >> -> + let fps = List.map ~f:sexp_of_type (Ast.list_of_ctyp tps []) in + let bindings, patts, vars = mk_bindings loc fps in + let cnstr_expr = <:expr@loc< Sexplib.Sexp.Atom $str:cnstr$ >> in + let expr = + <:expr@loc< + let $bindings$ in + Sexplib.Sexp.List $Gen.mk_expr_lst loc (cnstr_expr :: vars)$ + >> + in + <:match_case@loc< `$cnstr$ $Ast.paSem_of_list patts$ -> $expr$ >> + | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> + | <:ctyp< [= $row_fields$ ] >> -> loop row_fields + | <:ctyp@loc< $tp1$ $tp2$ >> -> + let id_path = Gen.get_appl_path loc tp1 in + let call = sexp_of_appl_fun loc tp1 tp2 in + <:match_case@loc< #$id_path$ as v -> $call$ v >> + | <:ctyp@loc< $id:id$ >> | <:ctyp@loc< #$id:id$ >> -> + let call = + match Gen.get_rev_id_path id [] with + | tn :: rev_path -> mk_abst_call loc tn rev_path + | [] -> assert false (* impossible *) + in + <:match_case@loc< #$id$ as v -> $call$ v >> + | tp -> Gen.unknown_type tp "sexp_of_variant" + in + `Match (loop row_fields) + + + (* Polymorphic record fields *) + + and sexp_of_poly parms tp = + let loc = Ast.loc_of_ctyp tp in + let bindings = + let mk_binding parm = + <:binding@loc< $lid:"_of_" ^ parm$ = Sexplib.Conv.sexp_of_opaque >> + in + List.map ~f:mk_binding (Gen.ty_var_list_of_ctyp parms []) + in + match sexp_of_type tp with + | `Fun fun_expr -> `Fun <:expr@loc< let $list:bindings$ in $fun_expr$ >> + | `Match matchings -> + `Match + <:match_case@loc< + arg -> + let $list:bindings$ in + match arg with + [ $matchings$ ] + >> + + + (* Conversion of sum types *) + + let rec branch_sum = function + | <:ctyp@loc< $tp1$ | $tp2$ >> -> + <:match_case@loc< $branch_sum tp1$ | $branch_sum tp2$ >> + | <:ctyp@loc< $uid:cnstr$ >> -> + <:match_case@loc< $uid:cnstr$ -> Sexplib.Sexp.Atom $str:cnstr$ >> + | <:ctyp@loc< $uid:cnstr$ of sexp_list $tp$>> -> + let cnv_expr = + match sexp_of_type tp with + | `Fun fun_expr -> <:expr@loc< $fun_expr$ >> + | `Match matchings -> + <:expr@loc< fun el -> match el with [ $matchings$ ] >> + in + <:match_case@loc< + $uid:cnstr$ l -> + Sexplib.Sexp.List + [Sexplib.Sexp.Atom $str:cnstr$ :: + Sexplib.Conv.list_map $cnv_expr$ l] + >> + | <:ctyp@loc< $uid:cnstr$ of $tps$ >> -> + let fps = List.map ~f:sexp_of_type (Ast.list_of_ctyp tps []) in + let cnstr_expr = <:expr@loc< Sexplib.Sexp.Atom $str:cnstr$ >> in + let bindings, patts, vars = mk_bindings loc fps in + let patt = + match patts with + | [patt] -> patt + | _ -> <:patt@loc< ( $tup:Ast.paCom_of_list patts$ ) >> + in + <:match_case@loc< + $uid:cnstr$ $patt$ -> + let $bindings$ in + Sexplib.Sexp.List $Gen.mk_expr_lst loc (cnstr_expr :: vars)$ + >> + | tp -> Gen.unknown_type tp "branch_sum" + + let sexp_of_sum alts = `Match (branch_sum alts) + + + (* Conversion of record types *) + + let mk_rec_patt loc patt name = + let p = <:patt@loc< $lid:name$ = $lid:"v_" ^ name$ >> in + <:patt@loc< $patt$; $p$ >> + + let sexp_of_default_field patt expr name tp sexp_of empty = + let loc = Ast.loc_of_ctyp tp in + let patt = mk_rec_patt loc patt name in + let cnv_expr = + match sexp_of_type tp with + | `Fun fun_expr -> <:expr@loc< $fun_expr$ >> + | `Match matchings -> + <:expr@loc< fun el -> match el with [ $matchings$ ] >> + in + let expr = + let v_name = <:expr@loc< $lid: "v_" ^ name$ >> in + <:expr@loc< + let bnds = + if $v_name$ = $empty$ then bnds + else + let arg = $sexp_of$ $cnv_expr$ $v_name$ in + let bnd = + Sexplib.Sexp.List [Sexplib.Sexp.Atom $str:name$; arg] + in + [ bnd :: bnds ] + in + $expr$ + >> + in + patt, expr + + let sexp_of_record flds_ctyp = + let flds = Ast.list_of_ctyp flds_ctyp [] in + let rec coll (patt, expr) = function + | <:ctyp@loc< $lid:name$ : mutable sexp_option $tp$ >> + | <:ctyp@loc< $lid:name$ : sexp_option $tp$ >> -> + let patt = mk_rec_patt loc patt name in + let vname = <:expr@loc< v >> in + let cnv_expr = unroll_cnv_fp loc vname (sexp_of_type tp) in + let expr = + <:expr@loc< + let bnds = + match $lid:"v_" ^ name$ with + [ None -> bnds + | Some v -> + let arg = $cnv_expr$ in + let bnd = + Sexplib.Sexp.List [Sexplib.Sexp.Atom $str:name$; arg] + in + [ bnd :: bnds ] ] + in + $expr$ + >> + in + patt, expr + | <:ctyp@loc< $lid:name$ : mutable sexp_bool >> + | <:ctyp@loc< $lid:name$ : sexp_bool >> -> + let patt = mk_rec_patt loc patt name in + let expr = + <:expr@loc< + let bnds = + if $lid:"v_" ^ name$ then + let bnd = Sexplib.Sexp.List [Sexplib.Sexp.Atom $str:name$] in + [ bnd :: bnds ] + else bnds + in + $expr$ + >> + in + patt, expr + | <:ctyp@loc< $lid:name$ : mutable sexp_list $tp$ >> + | <:ctyp@loc< $lid:name$ : sexp_list $tp$ >> -> + sexp_of_default_field + patt expr name tp <:expr@loc< sexp_of_list >> <:expr@loc< [] >> + | <:ctyp@loc< $lid:name$ : mutable sexp_array $tp$ >> + | <:ctyp@loc< $lid:name$ : sexp_array $tp$ >> -> + sexp_of_default_field + patt expr name tp <:expr@loc< sexp_of_array >> <:expr@loc< [||] >> + | <:ctyp@loc< $lid:name$ : mutable $tp$ >> + | <:ctyp@loc< $lid:name$ : $tp$ >> -> + let patt = mk_rec_patt loc patt name in + let vname = <:expr@loc< $lid:"v_" ^ name$ >> in + let cnv_expr = unroll_cnv_fp loc vname (sexp_of_type tp) in + let expr = + <:expr@loc< + let arg = $cnv_expr$ in + let bnd = Sexplib.Sexp.List [Sexplib.Sexp.Atom $str:name$; arg] in + let bnds = [ bnd :: bnds ] in + $expr$ + >> + in + patt, expr + | _ -> assert false (* impossible *) + in + let loc = Ast.loc_of_ctyp flds_ctyp in + let init_expr = <:expr@loc< Sexplib.Sexp.List bnds >> in + let patt, expr = + List.fold_left ~f:coll ~init:(<:patt@loc<>>, init_expr) flds + in + `Match + <:match_case@loc< + { $patt$ } -> + let bnds = [] in + $expr$ + >> + + + (* Empty type *) + let sexp_of_nil loc = `Fun <:expr@loc< fun _v -> assert False >> + + + (* Generate code from type definitions *) + + let sexp_of_td loc type_name tps rhs = + let body = + let rec loop tp = + Gen.switch_tp_def tp + ~alias:(fun (_ : Loc.t) tp -> sexp_of_type tp) + ~sum:(fun (_ : Loc.t) tp -> sexp_of_sum tp) + ~record:(fun (_ : Loc.t) tp -> sexp_of_record tp) + ~variants:(fun (_ : Loc.t) tp -> sexp_of_variant tp) + ~mani:(fun (_ : Loc.t) _tp1 tp2 -> loop tp2) + ~nil:sexp_of_nil + in + match loop rhs with + | `Fun fun_expr -> + (* Prevent violation of value restriction and problems with + recursive types by eta-expanding function definitions *) + <:expr@loc< fun [ v -> $fun_expr$ v ] >> + | `Match matchings -> <:expr@loc< fun [ $matchings$ ] >> + in + let mk_pat id = <:patt@loc< $lid:id$ >> in + let patts = + List.map tps + ~f:(fun ty -> <:patt@loc< $lid:"_of_" ^ Gen.get_tparam_id ty$>>) + in + let bnd = mk_pat ("sexp_of_" ^ type_name) in + <:binding@loc< $bnd$ = $Gen.abstract loc patts body$ >> + + let rec sexp_of_tds = function + | Ast.TyDcl (loc, type_name, tps, rhs, _cl) -> + sexp_of_td loc type_name tps rhs + | Ast.TyAnd (loc, tp1, tp2) -> + <:binding@loc< $sexp_of_tds tp1$ and $sexp_of_tds tp2$ >> + | _ -> assert false (* impossible *) + + let sexp_of tds = + let binding, recursive, loc = + match tds with + | Ast.TyDcl (loc, type_name, tps, rhs, _cl) -> + sexp_of_td loc type_name tps rhs, + Gen.type_is_recursive type_name rhs, loc + | Ast.TyAnd (loc, _, _) as tds -> sexp_of_tds tds, true, loc + | _ -> assert false (* impossible *) + in + if recursive then <:str_item@loc< value rec $binding$ >> + else <:str_item@loc< value $binding$ >> + + (* Add code generator to the set of known generators *) + let () = Pa_type_conv.add_generator "sexp_of" sexp_of + + let string_of_ident id = + let str_lst = Gen.get_rev_id_path id [] in + String.concat ~sep:"." str_lst + + let sexp_of_exn tp = + let get_full_cnstr cnstr = Pa_type_conv.get_conv_path () ^ "." ^ cnstr in + let expr = + match tp with + | <:ctyp@loc< $uid:cnstr$ >> -> + <:expr@loc< + Sexplib.Exn_magic.register $uid:cnstr$ $str:get_full_cnstr cnstr$ + >> + | <:ctyp@loc< $uid:cnstr$ of $tps$ >> -> + let ctyps = Ast.list_of_ctyp tps [] in + let fps = List.map ~f:sexp_of_type ctyps in + let sexp_converters = + List.map fps ~f:(function + | `Fun fun_expr -> <:expr@loc< $fun_expr$ >> + | `Match matchings -> <:expr@loc< fun [ $matchings$ ] >>) + in + let _, patts, vars = mk_bindings loc fps in + let register_name = sprintf "register%d" (List.length fps) in + let make_exc = + let var_args = + match vars with + | [var] -> var + | _ -> <:expr@loc< $tup:Ast.exCom_of_list vars$ >> + in + Gen.abstract loc patts <:expr@loc< $uid:cnstr$ $var_args$ >> + in + let call = + let partial = + <:expr@loc< + Sexplib.Exn_magic.$lid:register_name$ + $make_exc$ $str:get_full_cnstr cnstr$ + >> + in + Gen.apply loc partial sexp_converters + in + <:expr@loc< $call$ >> + | tp -> Gen.unknown_type tp "sexp_of_exn" + in + let loc = Ast.loc_of_ctyp tp in + <:str_item@loc< value () = $expr$ >> + + let () = Pa_type_conv.add_generator ~is_exn:true "sexp" sexp_of_exn +end + + +(* Generator for converters of S-expressions to OCaml-values *) +module Generate_of_sexp = struct + let mk_abst_call loc tn ?(internal = false) rev_path = + let tns = tn ^ "_of_sexp" in + let tns_suff = if internal then tns ^ "__" else tns in + <:expr@loc< $id:Gen.ident_of_rev_path loc (tns_suff :: rev_path)$ >> + + (* Utility functions for polymorphic variants *) + + (* Handle backtracking when variants do not match *) + let handle_no_variant_match loc expr = + <:match_case@loc< Sexplib.Conv_error.No_variant_match _ -> $expr$ >> + + let is_wildcard = function [_] -> true | _ -> false + + (* Generate code depending on whether to generate a match for the last + case of matching a variant *) + let handle_variant_match_last loc match_last matches = + if match_last || is_wildcard matches then + match matches with + | <:match_case< $_$ -> $expr$ >> :: _ -> expr + | _ -> assert false (* impossible *) + else <:expr@loc< match atom with [ $list:matches$ ] >> + + (* Generate code for matching malformed S-expressions *) + let mk_variant_other_matches loc rev_els call = + let coll_structs acc (loc, cnstr) = + <:match_case@loc< + $str:cnstr$ -> Sexplib.Conv_error.$lid:call$ _tp_loc _sexp + >> :: acc + in + let exc_no_variant_match = + <:match_case@loc< + _ -> Sexplib.Conv_error.no_variant_match _tp_loc _sexp + >> + in + List.fold_left ~f:coll_structs ~init:[exc_no_variant_match] rev_els + + (* Split the row fields of a variant type into lists of atomic variants, + structured variants, atomic variants + included variant types, + and structured variants + included variant types. *) + let rec split_row_field (atoms, structs, ainhs, sinhs as acc) = function + | <:ctyp@loc< `$cnstr$ >> -> + let tpl = loc, cnstr in + ( + tpl :: atoms, + structs, + `A tpl :: ainhs, + sinhs + ) + | <:ctyp@loc< `$cnstr$ of $tps$ >> -> + ( + atoms, + (loc, cnstr) :: structs, + ainhs, + `S (loc, cnstr, tps) :: sinhs + ) + | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> + | <:ctyp< [= $row_fields$ ] >> -> + List.fold_left ~f:split_row_field + ~init:acc (Ast.list_of_ctyp row_fields []) + | <:ctyp< $_$ $_$ >> + | (<:ctyp< $id:_$ >> | <:ctyp< #$id:_$ >>) as inh -> + let iinh = `I inh in + ( + atoms, + structs, + iinh :: ainhs, + iinh :: sinhs + ) + | tp -> Gen.unknown_type tp "split_row_field" + + (* Conversion of type paths *) + let path_of_sexp_fun loc id = + match Gen.get_rev_id_path id [] with + | tn :: rev_path -> mk_abst_call loc tn rev_path + | [] -> assert false (* no empty paths *) + + (* Conversion of types *) + let rec type_of_sexp = function + | <:ctyp@loc< sexp_opaque $_$ >> -> + `Fun <:expr@loc< Sexplib.Conv.opaque_of_sexp >> + | <:ctyp@loc< sexp_option >> -> + `Fun <:expr@loc< fun a_of_sexp v -> Some (a_of_sexp v) >> + | <:ctyp@loc< sexp_list >> -> + `Fun <:expr@loc< fun a_of_sexp v -> + Sexplib.Conv.list_of_sexp a_of_sexp v >> + | <:ctyp@loc< sexp_array >> -> + `Fun <:expr@loc< fun a_of_sexp v -> + Sexplib.Conv.array_of_sexp a_of_sexp v >> + | <:ctyp@loc< $tp1$ $tp2$ >> -> + let fp1 = type_of_sexp tp1 in + let fp2 = type_of_sexp tp2 in + `Fun (unroll_fun_matches loc fp1 fp2) + | <:ctyp< ( $tup:tp$ ) >> -> tuple_of_sexp tp + | <:ctyp@loc< '$parm$ >> -> `Fun <:expr@loc< $lid:"_of_" ^ parm$ >> + | <:ctyp@loc< $id:id$ >> -> `Fun (path_of_sexp_fun loc id) + | <:ctyp@loc< $_$ -> $_$ >> as arrow -> + `Fun <:expr@loc< fun sexp -> + (Sexplib.Conv.fun_of_sexp sexp : $arrow$) >> + | <:ctyp< [< $row_fields$ ] >> | <:ctyp< [> $row_fields$ ] >> + | <:ctyp< [= $row_fields$ ] >> -> + variant_of_sexp ?full_type:None row_fields + | <:ctyp< ! $parms$ . $poly_tp$ >> -> poly_of_sexp parms poly_tp + | tp -> Gen.unknown_type tp "type_of_sexp" + + (* Conversion of tuples *) + and tuple_of_sexp tps = + let fps = List.map ~f:type_of_sexp (Ast.list_of_ctyp tps []) in + let loc = Ast.loc_of_ctyp tps in + let bindings, patts, vars = mk_bindings loc fps in + let n = string_of_int (List.length fps) in + `Match + <:match_case@loc< + Sexplib.Sexp.List $Gen.mk_patt_lst loc patts$ -> + let $bindings$ in + ( $tup:Ast.exCom_of_list vars$ ) + | sexp -> + Sexplib.Conv_error.tuple_of_size_n_expected _tp_loc $int:n$ sexp + >> + + (* Generate internal call *) + and mk_internal_call = function + | <:ctyp@loc< $id:id$ >> | <:ctyp@loc< #$id:id$ >> -> + let call = + match Gen.get_rev_id_path id [] with + | tn :: rev_path -> mk_abst_call loc tn ~internal:true rev_path + | [] -> assert false (* impossible *) + in + call + | <:ctyp@loc< $tp1$ $tp2$ >> -> + let fp1 = `Fun (mk_internal_call tp1) in + let fp2 = type_of_sexp tp2 in + unroll_fun_matches loc fp1 fp2 + | _ -> assert false (* impossible *) + + (* Generate code for matching included variant types *) + and handle_variant_inh full_type match_last other_matches inh = + let loc = Ast.loc_of_ctyp inh in + let fun_expr = mk_internal_call inh in + let match_exc = + handle_no_variant_match loc ( + handle_variant_match_last loc match_last other_matches) in + let new_other_matches = + [ + <:match_case@loc< + _ -> try ($fun_expr$ _sexp :> $full_type$) with [ $match_exc$ ] + >> + ] + in + new_other_matches, true + + (* Generate code for matching atomic variants *) + and mk_variant_match_atom loc full_type rev_atoms_inhs rev_structs = + let coll (other_matches, match_last) = function + | `A (loc, cnstr) -> + let new_match = <:match_case@loc< $str:cnstr$ -> `$cnstr$ >> in + new_match :: other_matches, false + | `I inh -> + handle_variant_inh full_type match_last other_matches inh + in + let other_matches = + mk_variant_other_matches loc rev_structs "ptag_no_args" + in + let match_atoms_inhs, match_last = + List.fold_left ~f:coll ~init:(other_matches, false) rev_atoms_inhs in + handle_variant_match_last loc match_last match_atoms_inhs + + + (* Variant conversions *) + + (* Match arguments of constructors (variants or sum types) *) + and mk_cnstr_args_match ~is_variant cnstr tps = + let loc = Ast.loc_of_ctyp tps in + let cnstr vars_expr = + if is_variant then <:expr@loc< `$cnstr$ $vars_expr$ >> + else <:expr@loc< $uid:cnstr$ $vars_expr$ >> + in + match tps with + | <:ctyp@loc< sexp_list $tp$ >> -> + let cnv = + match type_of_sexp tp with + | `Fun fun_expr -> <:expr@loc< $fun_expr$ >> + | `Match matchings -> + <:expr@loc< fun el -> match el with [ $matchings$ ] >> + in + cnstr <:expr@loc< Sexplib.Conv.list_map ($cnv$) sexp_args >> + | _ -> + let fps = List.map ~f:type_of_sexp (Ast.list_of_ctyp tps []) in + let bindings, patts, vars = mk_bindings loc fps in + let good_arg_match = + let vars_expr = + match vars with + | [var_expr] -> var_expr + | _ -> <:expr@loc< ( $tup:Ast.exCom_of_list vars$ ) >> + in + cnstr vars_expr + in + let handle_exc = + if is_variant then "ptag_incorrect_n_args" + else "stag_incorrect_n_args" + in + <:expr@loc< + match sexp_args with + [ $Gen.mk_patt_lst loc patts$ -> let $bindings$ in $good_arg_match$ + | _ -> Sexplib.Conv_error.$lid:handle_exc$ _tp_loc _tag _sexp ] + >> + + (* Generate code for matching structured variants *) + and mk_variant_match_struct loc full_type rev_structs_inhs rev_atoms = + let has_structs_ref = ref false in + let coll (other_matches, match_last) = function + | `S (loc, cnstr, tps) -> + has_structs_ref := true; + let expr = mk_cnstr_args_match ~is_variant:true cnstr tps in + let new_match = + <:match_case@loc< ($str:cnstr$ as _tag) -> $expr$ >> + in + new_match :: other_matches, false + | `I inh -> + handle_variant_inh full_type match_last other_matches inh + in + let other_matches = + mk_variant_other_matches loc rev_atoms "ptag_no_args" + in + let match_structs_inhs, match_last = + List.fold_left ~f:coll ~init:(other_matches, false) rev_structs_inhs + in + ( + handle_variant_match_last loc match_last match_structs_inhs, + !has_structs_ref + ) + + (* Generate code for handling atomic and structured variants (i.e. not + included variant types) *) + and handle_variant_tag loc full_type row_fields = + let rev_atoms, rev_structs, rev_atoms_inhs, rev_structs_inhs = + List.fold_left ~f:split_row_field ~init:([], [], [], []) row_fields + in + let match_struct, has_structs = + mk_variant_match_struct loc full_type rev_structs_inhs rev_atoms in + let maybe_sexp_args_patt = + if has_structs then <:patt@loc< sexp_args >> + else <:patt@loc< _ >> + in + <:match_case@loc< + Sexplib.Sexp.Atom atom as _sexp -> + $mk_variant_match_atom loc full_type rev_atoms_inhs rev_structs$ + | Sexplib.Sexp.List + [Sexplib.Sexp.Atom atom :: $maybe_sexp_args_patt$] as _sexp -> + $match_struct$ + | Sexplib.Sexp.List [Sexplib.Sexp.List _ :: _] as sexp -> + Sexplib.Conv_error.nested_list_invalid_poly_var _tp_loc sexp + | Sexplib.Sexp.List [] as sexp -> + Sexplib.Conv_error.empty_list_invalid_poly_var _tp_loc sexp + >> + + (* Generate matching code for variants *) + and variant_of_sexp ?full_type row_tp = + let loc = Ast.loc_of_ctyp row_tp in + let row_fields = Ast.list_of_ctyp row_tp [] in + let is_contained, full_type = + match full_type with + | None -> true, <:ctyp@loc< [= $row_tp$ ] >> + | Some full_type -> false, full_type + in + let top_match = + match row_fields with + | (<:ctyp< $id:_$ >> | <:ctyp< $_$ $_$ >>) as inh :: rest -> + let rec loop inh row_fields = + let call = + <:expr@loc< ( $mk_internal_call inh$ sexp :> $full_type$ ) >> + in + match row_fields with + | [] -> call + | h :: t -> + let expr = + match h with + | <:ctyp< $id:_$ >> | <:ctyp< $_$ $_$ >> -> loop h t + | _ -> + let rftag_matches = + handle_variant_tag loc full_type row_fields + in + <:expr@loc< match sexp with [ $rftag_matches$ ] >> + in + <:expr@loc< + try $call$ with + [ $handle_no_variant_match loc expr$ ] + >> + in + <:match_case@loc< sexp -> $loop inh rest$ >> + | _ :: _ -> handle_variant_tag loc full_type row_fields + | [] -> assert false (* impossible *) + in + if is_contained then + `Fun + <:expr@loc< + fun sexp -> + try match sexp with [ $top_match$ ] + with + [ Sexplib.Conv_error.No_variant_match (_tp_loc, sexp) -> + Sexplib.Conv_error.no_matching_variant_found _tp_loc sexp + ] + >> + else `Match top_match + + and poly_of_sexp parms tp = + let loc = Ast.loc_of_ctyp tp in + let bindings = + let mk_binding parm = + <:binding@loc< + $lid:"_of_" ^ parm$ = + fun sexp -> Sexplib.Conv_error.record_poly_field_value _tp_loc sexp + >> + in + List.map ~f:mk_binding (Gen.ty_var_list_of_ctyp parms []) + in + match type_of_sexp tp with + | `Fun fun_expr -> `Fun <:expr@loc< let $list:bindings$ in $fun_expr$ >> + | `Match matchings -> + `Match + <:match_case@loc< + arg -> + let $list:bindings$ in + match arg with + [ $matchings$ ] + >> + + + (* Sum type conversions *) + + (* Generate matching code for well-formed S-expressions wrt. sum types *) + let rec mk_good_sum_matches = function + | <:ctyp@loc< $uid:cnstr$ >> -> + let lccnstr = String.uncapitalize cnstr in + <:match_case@loc< + Sexplib.Sexp.Atom ($str:lccnstr$ | $str:cnstr$) -> $uid:cnstr$ + >> + | <:ctyp@loc< $uid:cnstr$ of $tps$ >> -> + let lccnstr = String.uncapitalize cnstr in + <:match_case@loc< + (Sexplib.Sexp.List + [Sexplib.Sexp.Atom ($str:lccnstr$ | $str:cnstr$ as _tag) :: + sexp_args] as _sexp) -> + $mk_cnstr_args_match ~is_variant:false cnstr tps$ + >> + | <:ctyp@loc< $tp1$ | $tp2$ >> -> + <:match_case@loc< + $mk_good_sum_matches tp1$ + | $mk_good_sum_matches tp2$ + >> + | _ -> assert false (* impossible *) + + (* Generate matching code for malformed S-expressions with good tags + wrt. sum types *) + let rec mk_bad_sum_matches = function + | <:ctyp@loc< $uid:cnstr$ >> -> + let lccnstr = String.uncapitalize cnstr in + <:match_case@loc< + Sexplib.Sexp.List + [Sexplib.Sexp.Atom ($str:lccnstr$ | $str:cnstr$) :: _] as sexp -> + Sexplib.Conv_error.stag_no_args _tp_loc sexp + >> + | <:ctyp@loc< $uid:cnstr$ of $_$ >> -> + let lccnstr = String.uncapitalize cnstr in + <:match_case@loc< + Sexplib.Sexp.Atom ($str:lccnstr$ | $str:cnstr$) as sexp -> + Sexplib.Conv_error.stag_takes_args _tp_loc sexp + >> + | <:ctyp@loc< $tp1$ | $tp2$ >> -> + <:match_case@loc< + $mk_bad_sum_matches tp1$ + | $mk_bad_sum_matches tp2$ + >> + | _ -> assert false (* impossible *) + + (* Generate matching code for sum types *) + let sum_of_sexp alts = + let loc = Ast.loc_of_ctyp alts in + `Match + <:match_case@loc< + $mk_good_sum_matches alts$ + | $mk_bad_sum_matches alts$ + | Sexplib.Sexp.List [Sexplib.Sexp.List _ :: _] as sexp -> + Sexplib.Conv_error.nested_list_invalid_sum _tp_loc sexp + | Sexplib.Sexp.List [] as sexp -> + Sexplib.Conv_error.empty_list_invalid_sum _tp_loc sexp + | sexp -> Sexplib.Conv_error.unexpected_stag _tp_loc sexp + >> + + + (* Record conversions *) + + (* Generate code for extracting record fields *) + let mk_extract_fields tp = + let rec loop no_args args = function + | <:ctyp< $tp1$; $tp2$ >> -> + let no_args, args = loop no_args args tp2 in + loop no_args args tp1 + | <:ctyp@loc< $lid:nm$ : mutable sexp_bool >> + | <:ctyp@loc< $lid:nm$ : sexp_bool>> -> + let no_args = + <:match_case@loc< + $str:nm$ -> + if $lid:nm ^ "_field"$.val then + duplicates.val := [ field_name :: duplicates.val ] + else $lid:nm ^ "_field"$.val := True + | $no_args$ + >> + in + no_args, args + | <:ctyp@loc< $lid:nm$ : mutable sexp_option $tp$ >> + | <:ctyp@loc< $lid:nm$ : sexp_option $tp$ >> + | <:ctyp@loc< $lid:nm$ : mutable $tp$ >> + | <:ctyp@loc< $lid:nm$ : $tp$ >> -> + let unrolled = + unroll_cnv_fp loc <:expr@loc< _field_sexp >> (type_of_sexp tp) + in + let args = + <:match_case@loc< + $str:nm$ -> + match $lid:nm ^ "_field"$.val with + [ None -> + let fvalue = $unrolled$ in + $lid:nm ^ "_field"$.val := Some fvalue + | Some _ -> + duplicates.val := [ field_name :: duplicates.val ] ] + | $args$ + >> + in + no_args, args + | _ -> assert false (* impossible *) + in + let handle_extra = + let loc = Ast.loc_of_ctyp tp in + <:match_case@loc< + _ -> + if Sexplib.Conv.record_check_extra_fields.val then + extra.val := [ field_name :: extra.val ] + else () + >> + in + loop handle_extra handle_extra tp + + (* Generate code for handling the result of matching record fields *) + let mk_handle_record_match_result has_poly flds = + let has_nonopt_fields = ref false in + let res_tpls, bi_lst, good_patts = + let rec loop (res_tpls, bi_lst, good_patts as acc) = function + | <:ctyp@loc< $lid:nm$ : $tp$ >> -> + let fld = <:expr@loc< $lid:nm ^ "_field"$.val >> in + let new_bi_lst, new_good_patts = + match tp with + | <:ctyp@loc< sexp_bool >> | <:ctyp@loc< mutable sexp_bool >> + | <:ctyp@loc< sexp_option $_$ >> + | <:ctyp@loc< mutable sexp_option $_$ >> + | <:ctyp@loc< sexp_list $_$ >> + | <:ctyp@loc< mutable sexp_list $_$ >> + | <:ctyp@loc< sexp_array $_$ >> + | <:ctyp@loc< mutable sexp_array $_$ >> -> + bi_lst, <:patt@loc< $lid:nm ^ "_value"$ >> :: good_patts + | _ -> + let loc = Ast.loc_of_ctyp tp in + has_nonopt_fields := true; + ( + <:expr@loc< + (Pervasives.(=) $fld$ None, $str:nm$) >> :: bi_lst, + <:patt@loc< Some $lid:nm ^ "_value"$ >> :: good_patts + ) + in + ( + <:expr@loc< $fld$ >> :: res_tpls, + new_bi_lst, + new_good_patts + ) + | <:ctyp< $tp1$; $tp2$ >> -> loop (loop acc tp2) tp1 + | _ -> assert false (* impossible *) + in + loop ([], [], []) flds + in + let loc = Ast.loc_of_ctyp flds in + let match_good_expr = + if has_poly then + let rec loop acc = function + | <:ctyp< $tp1$; $tp2$ >> -> loop (loop acc tp2) tp1 + | <:ctyp@loc< $lid:nm$ : $_$ >> -> + <:expr@loc< $lid:nm ^ "_value"$ >> :: acc + | _ -> assert false (* impossible *) + in + match loop [] flds with + | [match_good_expr] -> match_good_expr + | match_good_exprs -> + <:expr@loc< $tup:Ast.exCom_of_list match_good_exprs$ >> + else + let rec loop = function + | <:ctyp@loc< $tp1$; $tp2$ >> -> + <:rec_binding@loc< $loop tp1$; $loop tp2$ >> + | <:ctyp@loc< $lid:nm$ : sexp_list $_$ >> -> + <:rec_binding@loc< + $lid:nm$ = + match $lid:nm ^ "_value"$ with + [ None -> [] | Some v -> v ] + >> + | <:ctyp@loc< $lid:nm$ : sexp_array $_$ >> -> + <:rec_binding@loc< + $lid:nm$ = + match $lid:nm ^ "_value"$ with + [ None -> [||] | Some v -> v ] + >> + | <:ctyp@loc< $lid:nm$ : $_$ >> -> + <:rec_binding@loc< $lid:nm$ = $lid:nm ^ "_value"$ >> + | _ -> assert false (* impossible *) + in + <:expr@loc< { $loop flds$ } >> + in + let expr, patt = + match res_tpls, good_patts with + | [res_expr], [res_patt] -> res_expr, res_patt + | _ -> + <:expr@loc< $tup:Ast.exCom_of_list res_tpls$ >>, + <:patt@loc< $tup:Ast.paCom_of_list good_patts$ >> + in + if !has_nonopt_fields then + <:expr@loc< + match $expr$ with + [ $patt$ -> $match_good_expr$ + | _ -> + Sexplib.Conv_error.record_undefined_elements _tp_loc sexp + $Gen.mk_expr_lst loc bi_lst$ + ] + >> + else <:expr@loc< match $expr$ with [ $patt$ -> $match_good_expr$ ] >> + + (* Generate code for converting record fields *) + let mk_cnv_fields has_poly flds = + let field_refs = + let rec loop = function + | <:ctyp@loc< $tp1$; $tp2$ >> -> + <:binding@loc< $loop tp1$ and $loop tp2$ >> + | <:ctyp@loc< $lid:nm$ : sexp_bool >> -> + <:binding@loc< $lid:nm ^ "_field"$ = ref False >> + | <:ctyp@loc< $lid:nm$ : $_$ >> -> + <:binding@loc< $lid:nm ^ "_field"$ = ref None >> + | _ -> assert false (* impossible *) + in + loop flds + in + let mc_no_args_fields, mc_fields_with_args = mk_extract_fields flds in + let loc = Ast.loc_of_ctyp flds in + <:expr@loc< + let $field_refs$ and duplicates = ref [] and extra = ref [] in + let rec iter = fun + [ [ + Sexplib.Sexp.List + [(Sexplib.Sexp.Atom field_name); _field_sexp] :: + tail + ] -> + do { + match field_name with + [ $mc_fields_with_args$ ]; + iter tail } + | [Sexplib.Sexp.List [(Sexplib.Sexp.Atom field_name)] :: tail] -> + do { + match field_name with + [ $mc_no_args_fields$ ]; + iter tail } + | [sexp :: _] -> + Sexplib.Conv_error.record_only_pairs_expected _tp_loc sexp + | [] -> () ] + in + do { + iter field_sexps; + if Pervasives.(<>) duplicates.val [] then + Sexplib.Conv_error.record_duplicate_fields + _tp_loc duplicates.val sexp + else if Pervasives.(<>) extra.val [] then + Sexplib.Conv_error.record_extra_fields _tp_loc extra.val sexp + else $mk_handle_record_match_result has_poly flds$ + } + >> + + let rec is_poly = function + | <:ctyp< $_$ : ! $_$ . $_$ >> -> true + | <:ctyp< $flds1$; $flds2$ >> -> is_poly flds1 || is_poly flds2 + | _ -> false + + (* Generate matching code for records *) + let record_of_sexp flds = + let loc = Ast.loc_of_ctyp flds in + let handle_fields = + let has_poly = is_poly flds in + let cnv_fields = mk_cnv_fields has_poly flds in + if has_poly then + let is_singleton_ref = ref true in + let patt = + let rec loop = function + | <:ctyp@loc< $tp1$; $tp2$ >> -> + is_singleton_ref := false; + <:patt@loc< $loop tp1$, $loop tp2$ >> + | <:ctyp@loc< $lid:nm$ : $_$ >> -> <:patt@loc< $lid:nm$ >> + | _ -> assert false (* impossible *) + in + let patt = loop flds in + if !is_singleton_ref then patt + else <:patt@loc< $tup:patt$ >> + in + let record_def = + let rec loop = function + | <:ctyp@loc< $tp1$; $tp2$ >> -> + <:rec_binding@loc< $loop tp1$; $loop tp2$ >> + | <:ctyp@loc< $lid:nm$ : $_$ >> -> + <:rec_binding@loc< $lid:nm$ = $lid:nm$ >> + | _ -> assert false (* impossible *) + in + loop flds + in + <:expr@loc< + let $patt$ = $cnv_fields$ in + { $record_def$ } + >> + else cnv_fields + in + `Match + <:match_case@loc< + Sexplib.Sexp.List field_sexps as sexp -> $handle_fields$ + | Sexplib.Sexp.Atom _ as sexp -> + Sexplib.Conv_error.record_list_instead_atom _tp_loc sexp + >> + + + (* Empty type *) + let nil_of_sexp loc = + `Fun <:expr@loc< fun sexp -> Sexplib.Conv_error.empty_type _tp_loc sexp >> + + + (* Generate code from type definitions *) + + let rec is_poly_call = function + | <:expr< $f$ $_$ >> -> is_poly_call f + | <:expr< $lid:name$ >> -> name.[0] = '_' && name.[1] = 'o' + | _ -> false + + let td_of_sexp loc type_name tps rhs = + let is_alias_ref = ref false in + let handle_alias tp = + is_alias_ref := true; + type_of_sexp tp + in + let coll_args tp param = + <:ctyp@loc< $tp$ $Gen.drop_variance_annotations param$ >> + in + let full_type = + List.fold_left ~f:coll_args ~init:<:ctyp@loc< $lid:type_name$ >> tps + in + let is_variant_ref = ref false in + let handle_variant row_fields = + is_variant_ref := true; + variant_of_sexp ~full_type row_fields + in + let body = + let rec loop tp = + Gen.switch_tp_def tp + ~alias:(fun (_ : Loc.t) tp -> handle_alias tp) + ~sum:(fun (_ : Loc.t) tp -> sum_of_sexp tp) + ~record:(fun (_ : Loc.t) tp -> record_of_sexp tp) + ~variants:(fun (_ : Loc.t) tp -> handle_variant tp) + ~mani:(fun (_ : Loc.t) _tp1 tp2 -> loop tp2) + ~nil:nil_of_sexp + in + match loop rhs with + | `Fun fun_expr -> + (* Prevent violation of value restriction and problems with + recursive types by eta-expanding function definitions *) + <:expr@loc< fun [ t -> $fun_expr$ t ] >> + | `Match matchings -> <:expr@loc< fun [ $matchings$ ] >> + in + let internal_name = type_name ^ "_of_sexp__" in + let arg_patts, arg_exprs = + List.split ( + List.map ~f:(function tp -> + let name = "_of_" ^ Gen.get_tparam_id tp in + <:patt@loc< $lid:name$ >>, <:expr@loc< $lid:name$ >> + ) + tps) + in + let with_poly_call = !is_alias_ref && is_poly_call body in + let internal_fun_body = + let full_type_name = + sprintf "%s.%s" (Pa_type_conv.get_conv_path ()) type_name + in + if with_poly_call then + Gen.abstract loc arg_patts + <:expr@loc< + fun sexp -> + Sexplib.Conv_error.silly_type $str:full_type_name$ sexp + >> + else + <:expr@loc< + let _tp_loc = $str:full_type_name$ in + $Gen.abstract loc arg_patts body$ + >> + in + let pre_external_fun_body = + let internal_call = + let internal_expr = <:expr@loc< $lid:internal_name$ >> in + <:expr@loc< $Gen.apply loc internal_expr arg_exprs$ sexp >> + in + let no_variant_match_mc = + <:match_case@loc< + Sexplib.Conv_error.No_variant_match (_tp_loc, sexp) -> + Sexplib.Conv_error.no_matching_variant_found _tp_loc sexp + >> + in + if with_poly_call then + <:expr@loc< try $body$ sexp with [ $no_variant_match_mc$ ] >> + (* Type alias may refer to variant, therefore same handling here! *) + else if !is_variant_ref || !is_alias_ref then + <:expr@loc< try $internal_call$ with [ $no_variant_match_mc$ ] >> + else internal_call + in + let internal_binding = + <:binding@loc< $lid:internal_name$ = $internal_fun_body$ >> + in + let external_fun_patt = <:patt@loc< $lid:type_name ^ "_of_sexp"$ >> in + let external_fun_body = + Gen.abstract loc arg_patts + <:expr@loc< fun sexp -> $pre_external_fun_body$ >> + in + let external_binding = + <:binding@loc< $external_fun_patt$ = $external_fun_body$ >> + in + internal_binding, external_binding + + let rec tds_of_sexp acc = function + | Ast.TyDcl (loc, type_name, tps, rhs, _cl) -> + td_of_sexp loc type_name tps rhs :: acc + | Ast.TyAnd (_, tp1, tp2) -> tds_of_sexp (tds_of_sexp acc tp2) tp1 + | _ -> assert false (* impossible *) + + (* Generate code from type definitions *) + let of_sexp = function + | Ast.TyDcl (loc, type_name, tps, rhs, _cl) -> + let internal_binding, external_binding = + td_of_sexp loc type_name tps rhs + in + let recursive = Gen.type_is_recursive type_name rhs in + if recursive then + <:str_item@loc< + value rec $internal_binding$ + and $external_binding$ + >> + else + <:str_item@loc< + value $internal_binding$; + value $external_binding$ + >> + | Ast.TyAnd (loc, _, _) as tds -> + let two_bindings = tds_of_sexp [] tds in + let bindings = + List.map ~f:(fun (b1, b2) -> <:binding@loc< $b1$ and $b2$ >>) + two_bindings + in + <:str_item@loc< value rec $list:bindings$ >> + | _ -> assert false (* impossible *) + + (* Add code generator to the set of known generators *) + let () = Pa_type_conv.add_generator "of_sexp" of_sexp +end + +module Quotations = struct + let of_sexp_quote loc _loc_name_opt cnt_str = + Pa_type_conv.set_conv_path_if_not_set loc; + let ctyp = Gram.parse_string Syntax.ctyp_quot loc cnt_str in + let fp = Generate_of_sexp.type_of_sexp ctyp in + let body = + match fp with + | `Fun fun_expr -> <:expr@loc< $fun_expr$ sexp >> + | `Match matchings -> <:expr@loc< match sexp with [$matchings$] >> + in + let full_type_name = + sprintf "%s line %i: %s" + (Pa_type_conv.get_conv_path ()) (Loc.start_line loc) cnt_str + in + <:expr@loc< + fun [ sexp -> + let _tp_loc = $str:full_type_name$ in + $body$ ] + >> + + let () = + Syntax.Quotation.add "of_sexp" Syntax.Quotation.DynAst.expr_tag + of_sexp_quote + + let sexp_of_quote loc _loc_name_opt cnt_str = + Pa_type_conv.set_conv_path_if_not_set loc; + let ctyp = Gram.parse_string Syntax.ctyp_quot loc cnt_str in + Generate_sexp_of.mk_cnv_expr ctyp + + let () = + Syntax.Quotation.add "sexp_of" Syntax.Quotation.DynAst.expr_tag + sexp_of_quote +end + +(* Add "of_sexp" and "sexp_of" as "sexp" to the set of generators *) +let () = + Pa_type_conv.add_generator + "sexp" + (fun tds -> + let loc = Ast.loc_of_ctyp tds in + <:str_item@loc< + $Generate_of_sexp.of_sexp tds$; $Generate_sexp_of.sexp_of tds$ + >> + )