/usr/lib/ocaml/odn/pa_odn.ml is in libodn-ocaml-dev 0.0.11-1build4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 | (******************************************************************************)
(* ocaml-data-notation: Store data using OCaml notation *)
(* *)
(* Copyright (C) 2009-2011, OCamlCore SARL *)
(* Copyright (C) 2013, Sylvain Le Gall *)
(* *)
(* 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.1 of the License, or (at *)
(* your option) any later version, with the OCaml static compilation *)
(* exception. *)
(* *)
(* 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 file COPYING 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *)
(******************************************************************************)
(** Syntax extension that adds function converting
data into ODN.t using type declaration to guess
how to do.
@author Sylvain Le Gall
*)
open Camlp4;;
open PreCast;;
open Ast;;
open Pa_type_conv;;
let dbug =
prerr_endline
;;
let odn_fun_name tn =
"odn_of_"^tn
;;
let odn_id_name _loc tn rev_path =
Gen.ident_of_rev_path _loc ((odn_fun_name tn) :: rev_path)
;;
let odn_patt_name _loc tn =
<:patt< $lid:odn_fun_name tn$ >>
;;
let rec odn_of_tuple _loc tps =
let patts, exprs, _ =
List.fold_left
(fun (acc_patt, acc_expr, i) tp ->
let vnm =
"v"^(string_of_int i)
in
<:patt< $lid:vnm$ >> :: acc_patt,
<:expr< $odn_of_type _loc tp$ $lid:vnm$ >> :: acc_expr,
i + 1)
([], [], 0)
(List.rev
(list_of_ctyp tps []))
in
let patt =
match patts with
| [patt] -> patt
| _ -> <:patt<($tup:paCom_of_list patts$)>>
in
<:expr<fun $patt$ ->
ODN.TPL($Gen.mk_expr_lst _loc exprs$)>>
and odn_of_variants _loc vrts =
let lst =
list_of_ctyp vrts []
in
let lst' =
List.map
(function
| <:ctyp<`$cnstr$>> ->
<:match_case<`$cnstr$ -> ODN.PVR ($str:cnstr$, None) >>
| <:ctyp<`$cnstr$ of $tps$>> ->
begin
let vnm = "tpl" in
let var_expr = <:expr< $lid:vnm$ >> in
let var_patt = <:patt< $lid:vnm$ >> in
let expr =
<:expr<$odn_of_tuple _loc tps$ $var_expr$>>
in
<:match_case<`$uid:cnstr$ $var_patt$ ->
ODN.PVR($str:cnstr$, Some $expr$)>>
end
| _ ->
assert false)
lst
in
<:expr<function $mcOr_of_list lst'$>>
and odn_of_type _loc =
function
| <:ctyp<$id:id$>> ->
begin
match Gen.get_rev_id_path id [] with
| ["unit"] -> <:expr<ODN.of_unit>>
| ["bool"] -> <:expr<ODN.of_bool>>
| ["string"] -> <:expr<ODN.of_string>>
| ["int"] -> <:expr<ODN.of_int>>
| ["float"] -> <:expr<ODN.of_float>>
| tn :: rev_path ->
<:expr<$id:odn_id_name _loc tn rev_path$>>
| [] ->
assert false
end
| <:ctyp<($tp$ option)>> ->
<:expr<function x -> ODN.of_option $odn_of_type _loc tp$ x>>
| <:ctyp<($tp$ list)>> ->
<:expr<function x -> ODN.of_list $odn_of_type _loc tp$ x>>
| <:ctyp<($tp1$ $tp2$)>> ->
<:expr<$odn_of_type _loc tp2$ $odn_of_type _loc tp1$>>
| <:ctyp<'$parm$>> ->
<:expr<$id:odn_id_name _loc parm []$>>
| <:ctyp< ( $tup:tp$ ) >> ->
odn_of_tuple _loc tp
| <:ctyp<[$vrts$]>> ->
odn_of_variants _loc vrts
| _ ->
assert false
;;
let odn_of_alias _loc ctp =
<:expr<$odn_of_type _loc ctp$>>
;;
let odn_of_sum _loc ctp =
let sum_def =
let sum_name nm =
get_conv_path ()^"."^nm
in
let rec sum_fold _loc =
function
| TyOr (_loc, tp1, tp2) ->
<:match_case<$sum_fold _loc tp1$ | $sum_fold _loc tp2$>>
| TyId (_loc, IdUid(_, cnstr)) ->
<:match_case<$uid:cnstr$ -> ODN.VRT($str:sum_name cnstr$,[])>>
| TyOf (_loc, TyId(_, IdUid(_, cnstr)), tps) ->
let patts, exprs, _ =
List.fold_left
(fun (acc_patt, acc_expr, i) tp ->
let vnm =
"v"^(string_of_int i)
in
<:patt< $lid:vnm$ >> :: acc_patt,
<:expr< $odn_of_type _loc tp$ $lid:vnm$ >> :: acc_expr,
i + 1)
([], [], 0)
(List.rev
(list_of_ctyp tps []))
in
let patt =
match patts with
| [patt] -> patt
| _ -> <:patt<($tup:paCom_of_list patts$)>>
in
<:match_case<$uid:cnstr$ $patt$ ->
ODN.VRT($str:sum_name cnstr$, $Gen.mk_expr_lst _loc exprs$)>>
| ty ->
assert false
in
sum_fold _loc ctp
in
<:expr<function $sum_def$>>
;;
let odn_of_record _loc ctp =
let rec_def =
let rec rec_map =
function
| TyCol(_loc, TyId(_, IdLid(_, nm)), ctp) ->
<:expr<$str:nm$, $odn_of_type _loc ctp$ v.$lid:nm$>>
| ty ->
assert false
in
List.map rec_map (list_of_ctyp ctp [])
in
<:expr<
fun v ->
ODN.REC ($str:get_conv_path ()$,
$Gen.mk_expr_lst _loc rec_def$)>>
;;
let odn_of_mani _loc ctp1 ctp2 =
dbug "mani";
assert false
;;
let odn_of_nil _loc =
dbug "nil";
assert false
;;
let odn_of _ tp =
let rec odn_aux =
function
| TyDcl (_loc, type_name, tps, rhs, _cl) ->
let body =
Gen.switch_tp_def
~alias:odn_of_alias
~sum:odn_of_sum
~record:odn_of_record
~variants:odn_of_variants
~mani:odn_of_mani
~nil:odn_of_nil
rhs
in
let patts =
List.map
(fun tp -> odn_patt_name _loc (Gen.get_tparam_id tp))
tps
in
let fun_name =
odn_id_name _loc type_name []
in
<:binding<$id:fun_name$ = $Gen.abstract _loc patts body$>>
| TyAnd (_loc, tp1, tp2) ->
<:binding<$odn_aux tp1$ and $odn_aux tp2$>>
| _ ->
assert false
in
let _loc, recursive =
match tp with
| TyDcl (_loc, type_name, _, rhs, _) ->
_loc, Gen.type_is_recursive type_name rhs
| TyAnd (_loc, _, _) ->
_loc, true
| _ -> assert false
in
if recursive then
<:str_item<let rec $odn_aux tp$>>
else
<:str_item<let $odn_aux tp$>>
;;
add_generator
"odn"
odn_of
;;
|