--- /dev/null
+(******************************************************************************
+ * 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 <msandin@hotmail.com> *
+ * *
+ * *
+ * 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$
+ >>
+ )
HCoop / bpt / coccinelle.git / blobdiff