├── .gitignore ├── META ├── Makefile ├── README.md ├── create.ml ├── helper.ml ├── insert.ml ├── mod.ml ├── ocaml_at_p.ml ├── opam ├── v1.0.1 │ └── opam ├── v1.0 │ └── opam └── v1.1.0 │ ├── descr │ ├── opam │ └── url ├── print.ml └── test ├── Makefile ├── mylist.ml └── test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | memo.txt 12 | ocaml_at_p.opt 13 | 14 | 15 | # ocamlbuild working directory 16 | _build/ 17 | 18 | # ocamlbuild targets 19 | *.byte 20 | *.native 21 | 22 | # oasis generated files 23 | setup.data 24 | setup.log 25 | -------------------------------------------------------------------------------- /META: -------------------------------------------------------------------------------- 1 | name="ocaml_at_p" 2 | version="1.0.1" 3 | description="debug printer with [@p] markers" 4 | requires="compiler-libs.common,typpx" 5 | ppx="./ocaml_at_p.opt" 6 | archive(byte)="print.cmo" 7 | archive(native)="print.cmx" 8 | linkopts="" 9 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | #macro define 2 | FIND = ocamlfind 3 | OC = ocamlc 4 | OPT = ocamlopt 5 | FA = -package compiler-libs -linkpkg 6 | FB = -package typpx,compiler-libs -linkpkg 7 | 8 | LINK = helper.cmx insert.cmx create.cmx mod.cmx ocaml_at_p.cmx 9 | 10 | #build 11 | build: print.cmo print.cmx ocaml_at_p.opt 12 | 13 | print.cmo : print.ml 14 | $(FIND) $(OC) $(FA) -c print.ml 15 | 16 | print.cmx : print.ml 17 | $(FIND) $(OPT) $(FA) -c print.ml 18 | 19 | #ocamlopt 20 | ocaml_at_p.opt : helper.cmx insert.cmx create.cmx mod.cmx ocaml_at_p.cmx 21 | $(FIND) $(OPT) $(FB) -o ocaml_at_p.opt ${LINK} 22 | 23 | helper.cmx : helper.ml 24 | $(FIND) $(OPT) $(FA) -c helper.ml 25 | 26 | insert.cmx : insert.ml 27 | $(FIND) $(OPT) $(FA) -c insert.ml 28 | 29 | create.cmx : create.ml 30 | $(FIND) $(OPT) $(FA) -c create.ml 31 | 32 | mod.cmx : mod.ml 33 | $(FIND) $(OPT) $(FB) -c mod.ml 34 | 35 | ocaml_at_p.cmx : ocaml_at_p.ml 36 | $(FIND) $(OPT) $(FB) -c ocaml_at_p.ml 37 | 38 | #install,uninstall 39 | install : build 40 | $(FIND) install ocaml_at_p META ocaml_at_p.opt print.cm* print.o 41 | 42 | remove: 43 | -$(FIND) remove ocaml_at_p 44 | 45 | #clean 46 | clean: 47 | -rm *.cm* *.o ocaml_at_p.opt 48 | 49 | reset: clean remove 50 | 51 | reinstall: reset install 52 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | #OCaml@p : A debugging print system for OCaml 2 | 3 | OCaml@p is a tool supporting debug in OCaml programming. When you compile a program by this tool, this tool generates definition of print function automatically, and inserts function calls to print expression attached marker [@p] automatically. 4 | 5 | note : This tool doesn't consider use in combination with other PPX tools using attributes. 6 | 7 | #How to use 8 | 9 | ##installation 10 | Version : 1.1.0 11 | 12 | required OCaml version : OCaml 4.03.0 13 | 14 | OPAM released 15 | 16 | install 17 | 18 | ``` 19 | opam install ocaml_at_p 20 | ``` 21 | 22 | uninstall 23 | 24 | ``` 25 | opam remove ocaml_at_p 26 | ``` 27 | 28 | ##How to compile with OCaml@p 29 | 30 | When you compile a.ml with OCaml@p 31 | 32 | ``` 33 | ocamlfind ocamlc(ocamlopt) -package ocaml_at_p -linkpkg a.ml 34 | ``` 35 | 36 | ##How to write code 37 | 38 | ###Marker for print 39 | 40 | In OCaml@p, when you write marker [@p] behind expression that you want to print the return value, so you can print. The marker [@p] is attribute syntax in OCaml. 41 | 42 | ``` 43 | let add x y = x + y [@p x] [@p y] [@p] [@p _this+100] 44 | 45 | let a = add 1 10 46 | let b [@p] = a 47 | ``` 48 | 49 | Then，markers (`[@p x],[@p y],[@p]`) are attached the expression (`x + y`)．Two marker `[@p x]` and `[@p y]` are used to print values of expressions `x` and `y` ，and the marker `[@p]` is the value of the expression `x + y`．The variable `_this` is specific one bound by result of evaluation to expression (`x + y`). `_this` is the special variable bound by the result value of evaluating the expression. The following is result of run the program. 50 | 51 | ``` 52 | 1 <- at [@p x] 53 | 10 <- at [@p y] 54 | 11 <- at [@p] 55 | 111 <- at [@p _this+100] 56 | b = 11 <- at "let b [@p] = a" 57 | ``` 58 | 59 | ###Marker types 60 | 61 | There are two types marker `[@p]`, `[@ps]`, `let x [@p]`. 62 | 63 | * `e [@p]` - newline after printing e 64 | 65 | * `e [@p expr]` - newline after printing expr 66 | 67 | * `e [@ps]` - not newline after printing e 68 | 69 | * `e [@ps expr]` - not newline after printing expr 70 | 71 | * `let x [@p] = e` - newline after printting "x = " and e 72 | 73 | ###Outer module check [@@@ppopen] 74 | 75 | This tool cannot be sure to define print function that print a value of datatype defined in other ml files, so it is difficulty for users to understand error messages. Then, users need to write `[@@@ppopen module_name]` in Toplevel of ml file written markers to be clear that the ml files of module are compiled by OCaml@p. 76 | 77 | ##limitation 78 | 79 | ###module from functor(TODO) 80 | A program using module generated by functor connot be compiled with OCaml@p. OCaml@p change signature, and functor's arguments signature is also changed. So it cause type error. 81 | 82 | ###polymorphic value 83 | OCaml@p cannot print polymorphic values e.g. internal a polymorphic function. For example, the marker `[@p xs]` in the function `length` cannot print. 84 | 85 | ``` 86 | let rec length = function 87 | | [] -> 0 88 | | x::xs -> 1 + length xs [@p xs] 89 | ``` 90 | 91 | --- 92 | 93 | # OCaml@p : OCamlにおけるデバッグ出力機構 94 | 95 | OCamlプログラムのデバッグ出力をサポートするツールです．このツールを用いてコンパイルすると，型定義から型に対応した出力関数定義を自動生成します．また，マーカ[@p]のついた式を出力する関数呼び出しを自動で挿入します． 96 | 97 | 注 : 本システムでは他のattributeを用いたPPXツールとの併用は考慮していません． 98 | 99 | #使用方法 100 | 101 | ##インストール方法 102 | Version : 1.1.0 103 | 104 | 必要な OCaml version : OCaml 4.03.0 105 | 106 | opam でリリースされています 107 | 108 | install 109 | 110 | ``` 111 | opam install ocaml_at_p 112 | ``` 113 | 114 | uninstall 115 | 116 | ``` 117 | opam remove ocaml_at_p 118 | ``` 119 | 120 | ##OCaml@pを用いたコンパイル方法 121 | 122 | a.mlをOCaml@pでコンパイルするとき 123 | 124 | ``` 125 | ocamlfind ocamlc -package ocaml_at_p -linkpkg a.ml 126 | ``` 127 | 128 | ##コードの記述方法 129 | 130 | ###出力マーカ [@p] 131 | 132 | OCaml@pでは返す値を出力したい式にマーカ[@p]を記述することで，出力することができます．マーカはOCamlのattribute構文を用いています． 133 | 134 | 135 | ``` 136 | let add x y = x + y [@p x] [@p y] [@p] [@p _this+100] 137 | 138 | let a = add 1 10 139 | let b [@p] = a 140 | ``` 141 | 142 | ここで，`[@p x],[@p y],[@p]`は式`x + y`に付与されています．`[@p x],[@p y]`はそれぞれ`x,y`の値を，`[@p]`は`x + y`の値を出力します．`_this`は特別な変数で，式`x + y`の評価結果が束縛されている．このプログラムを実行した時の出力結果は以下のようになります． 143 | 144 | ``` 145 | 1 <- [@p x] の出力 146 | 10 <- [@p y] の出力 147 | 11 <- [@p] の出力 148 | 111 <- [@p _this+100] の出力 149 | b = 11 <- let b [@p] = a での出力 150 | ``` 151 | 152 | ###マーカの種類 153 | 154 | マーカは5種類存在する． 155 | 156 | * `e [@p]` - `e`の評価結果を出力後に改行 157 | 158 | * `e [@p expr]` - `expr`の評価結果を出力後に改行 159 | 160 | * `e [@ps]` - `e`の評価結果を出力後に改行しない 161 | 162 | * `e [@ps expr]` - `expr`の評価結果を出力後に改行しない 163 | 164 | * `let x [@p] = e` - `"x = "`と`e`の評価結果を改行 165 | 166 | ###外部モジュールチェック [@@@ppopen] 167 | 168 | 本システムでは他のmlファイル内で定義されたデータ型を出力する際に，出力関数が定義されているか確かめる術がないため，Unboundエラーが出てしまい、エラー内容がわかりづらい．そこで，そのモジュールのmlファイルがOCaml@pを用いてコンパイルされていることを、ユーザが出力を行うファイルのトップレベルに`[@@@ppopen モジュール名]`と記述するようにした． 169 | 170 | ##制限 171 | 172 | ###ファンクターを用いたモジュール 173 | OCaml@pはモジュールの型シグネチャを書き換えるので，ファンクタの引数に要求されるモジュールの型シグネチャも書き換える．これにより，型エラーを引き起こしてしまう．対応検討中． 174 | 175 | ###多相型の値 176 | OCaml@pでは，例えば多相関数の中に現れるような，型の定まらない多相型の値を出力することができない．例えば，次のような関数内のマーカ`[@p xs]`は出力できない． 177 | 178 | ``` 179 | let rec length = function 180 | | [] -> 0 181 | | x::xs -> 1 + length xs [@p xs] 182 | ``` 183 | -------------------------------------------------------------------------------- /create.ml: -------------------------------------------------------------------------------- 1 | open Asttypes 2 | open Typedtree 3 | open Helper 4 | open Longident 5 | 6 | (* 7 | (* core_type Ttyp_var to string *) 8 | let get_name ct = 9 | match ct.ctyp_desc with 10 | | Ttyp_var s -> s 11 | | _ -> failwith "TODO" 12 | 13 | (* fun _pp_1 -> ... -> expr : expression -> (core_type * variance) list -> expression *) 14 | let fun_exp exp ls = 15 | let rec loop acc = function 16 | | [] -> acc 17 | | x::xs -> 18 | let name = "_arg_" ^ get_name x in 19 | loop (make_Texp_fun name acc) xs 20 | in 21 | loop (app_prfx exp) (List.rev (List.map fst ls)) 22 | *) 23 | 24 | (* 25 | * make pp for variant 26 | * *) 27 | let make_variant_expr const_decl_list = 28 | let rec make_caselist_from_cdlist acc = function 29 | | [] -> List.rev acc 30 | | {cd_name = {txt=name;_};cd_args = Cstr_tuple core_type_list;_}::xs -> 31 | make_caselist_from_cdlist 32 | ({ c_lhs = make_Tpat_construct (Lident name) (pat_list (List.length core_type_list)); 33 | c_guard = None; 34 | c_rhs = make_Texp_tuple 35 | [make_Texp_constant (Const_string (name,None)); 36 | make_cps_expr_cty 1 core_type_list]} :: acc) 37 | xs 38 | | _::xs -> failwith "TODO" 39 | in 40 | let case_list = make_caselist_from_cdlist [] const_decl_list 41 | in 42 | make_Texp_apply (make_Texp_ident (path_ident_create "_pp__variant")) 43 | [Nolabel,Some (make_Texp_function case_list)] 44 | 45 | (* 46 | * make pp for record 47 | * *) 48 | let make_record_expr label_decl_list = 49 | let make_caselist_from_ldlist () = 50 | let rec make_pp_fields = function 51 | | [] -> make_Texp_construct (Lident "[]") [] 52 | | {ld_name = {txt=name;_};ld_type = ctype;_ }::xs -> 53 | make_Texp_construct 54 | (Lident "::") 55 | [make_Texp_tuple 56 | [make_Texp_constant (Const_string (name,None)); 57 | make_Texp_apply 58 | (make_Texp_apply 59 | (make_Texp_ident (path_ident_create "!%")) 60 | [Nolabel,Some (select_pp_core ctype)]) 61 | [Nolabel,Some (make_Texp_field (make_Texp_ident (path_ident_create "_arg")) (Lident name))]]; 62 | make_pp_fields xs] 63 | in 64 | let expression = make_pp_fields label_decl_list 65 | in 66 | [{ c_lhs = make_Tpat_var "_arg"; 67 | c_guard = None; 68 | c_rhs = expression }] 69 | in 70 | let case_list = make_caselist_from_ldlist () 71 | in 72 | make_Texp_apply (make_Texp_ident (path_ident_create "_pp__record")) 73 | [Nolabel,Some (make_Texp_function case_list)] 74 | 75 | (* type_declaration to pp 76 | * 77 | * variant record abstract extension_open*) 78 | let make_pp_type = 79 | function 80 | (* manifest *) 81 | | { typ_name = {txt=name;_}; typ_params = params; typ_manifest = Some ty;_ } -> 82 | Hashtbl.add params_tbl name params; 83 | make_vb name (fun_exp (select_pp_core ~ty_name:name ty) params) 84 | (* variant *) 85 | | { typ_name = {txt=name;_}; typ_params = params; typ_kind = Ttype_variant const_decl_list;_ } -> 86 | let expression = make_variant_expr const_decl_list in 87 | make_vb name (fun_exp expression params) 88 | (* record *) 89 | | { typ_name = {txt=name;_}; typ_params = params; typ_kind = Ttype_record label_decl_list;_ } -> 90 | let expression = make_record_expr label_decl_list in 91 | make_vb name (fun_exp expression params) 92 | (* type_extension open *) 93 | | { typ_name = {txt=name;_}; typ_params = params; typ_kind = Ttype_open;_ } -> 94 | let expression = make_Texp_ident (path_ident_create "_pp__trash") in 95 | Hashtbl.add caselist_tbl name []; 96 | make_vb name (fun_exp expression params) 97 | | { typ_name = {txt=name;_};_ } -> 98 | make_vb name (select_pp type_none) 99 | 100 | (* create each type printer from type_declaration list *) 101 | let make_pp_type_set type_decl_list ret = 102 | let rec from_list acc = function 103 | | [] -> acc 104 | | x::xs -> 105 | from_list (make_pp_type x :: acc) xs 106 | in 107 | let vb_list = from_list [] type_decl_list in 108 | (make_Tstr_val vb_list) :: ret 109 | 110 | (* 111 | * create type_extension printer from type_extension 112 | * *) 113 | let make_ext_expr ty_name ex_cons_list = 114 | let rec make_caselist_from_exconslist acc = function 115 | | [] -> List.rev acc 116 | | { ext_name = {txt=name;_}; ext_kind = Text_decl (Cstr_tuple core_type_list,_);_ }::xs -> 117 | make_caselist_from_exconslist 118 | ({ c_lhs = make_Tpat_construct (Lident name) (pat_list (List.length core_type_list)); 119 | c_guard = None; 120 | c_rhs = make_Texp_tuple 121 | [make_Texp_constant (Const_string (name,None)); 122 | make_cps_expr_cty 1 core_type_list]} :: acc) 123 | xs 124 | | _ -> failwith "TODO" 125 | in 126 | let start = List.rev (Hashtbl.find caselist_tbl ty_name) in 127 | let case_list = make_caselist_from_exconslist start ex_cons_list in 128 | Hashtbl.add caselist_tbl ty_name case_list; 129 | make_Texp_apply (make_Texp_ident (path_ident_create "_pp__variant")) 130 | [Nolabel,Some (make_Texp_function case_list)] 131 | 132 | 133 | let make_pp_type_ext type_ext ret = 134 | match type_ext with 135 | | { tyext_txt = {txt=Lident name;_}; tyext_params = params; tyext_constructors = consl;_ } -> 136 | let expression = fun_exp (make_ext_expr name consl) params in 137 | let vb_list = [make_vb name expression] in 138 | (make_Tstr_val vb_list) :: ret 139 | | { tyext_txt = {txt=name;_};_ } -> 140 | let vb_list = [make_vb (last name) (make_Texp_ident (path_ident_create "_pp__unsup"))] in 141 | (make_Tstr_val vb_list) :: ret 142 | 143 | let make_pp_sig_type_set type_decl_list ret = 144 | let rec from_list acc = function 145 | | [] -> List.rev acc 146 | | { typ_name = {txt=name;_}; typ_params = params; _ }::xs -> 147 | from_list (make_Tsig_val ("_pp_"^name) (set_ps name params) :: acc) xs 148 | in 149 | let sigl = from_list [] type_decl_list in 150 | sigl @ ret 151 | 152 | let make_pp_sig_type_ext type_ext ret = 153 | match type_ext with 154 | | { tyext_txt = {txt=Lident name;_}; tyext_params = params; _ } -> 155 | (make_Tsig_val ("_pp_"^name) (set_ps name params)) :: ret 156 | | { tyext_params = params; _ } -> 157 | (make_Tsig_val "_pp_unsup" (set_ps "_pp_unsup" params)) :: ret 158 | 159 | (* 160 | * create class printer from class_declaration 161 | *) 162 | let from_classfields class_fields = 163 | let rec make_pp_fields = function 164 | | [] -> make_Texp_construct (Lident "[]") [] 165 | | { cf_desc = Tcf_method ({txt=name;_},Public,Tcfk_concrete (_,{exp_type={Types.desc=Types.Tarrow (_,_,typ,_)};_}));_ }::xs -> 166 | let typ_s = Format.asprintf "%a" Printtyp.type_expr typ in 167 | make_Texp_construct 168 | (Lident "::") 169 | [make_Texp_tuple 170 | [make_Texp_constant (Const_string (name,None)); 171 | make_Texp_apply 172 | (make_Texp_apply 173 | (make_Texp_ident (path_ident_create "!%")) 174 | [Nolabel,Some (make_Texp_apply 175 | (make_Texp_ident (path_ident_create "_pp__dump")) 176 | [Nolabel,Some (make_Texp_constant (Const_string (typ_s,None)))])]) 177 | [Nolabel,Some (make_Texp_construct (Lident "()") [])]]; 178 | make_pp_fields xs] 179 | | { cf_desc = Tcf_constraint _;_ }::xs -> 180 | print_endline "TODO"; 181 | make_pp_fields xs 182 | | { cf_desc = Tcf_initializer _;_ }::xs -> 183 | print_endline "TODO"; 184 | make_pp_fields xs 185 | | { cf_desc = Tcf_attribute _;_ }::xs -> 186 | print_endline "TODO"; 187 | make_pp_fields xs 188 | | _::xs -> 189 | make_pp_fields xs 190 | in 191 | let expression = make_pp_fields class_fields in 192 | let case_list = 193 | [{ c_lhs = make_Tpat_any; 194 | c_guard = None; 195 | c_rhs = expression }] 196 | in 197 | make_Texp_apply (make_Texp_ident (path_ident_create "_pp__object")) 198 | [Nolabel,Some (make_Texp_function case_list)] 199 | 200 | 201 | let rec make_exp_class class_expr = 202 | match class_expr.cl_desc with 203 | | Tcl_ident (_,{txt = name;_},_) -> 204 | make_Texp_ident (path_set (longident_to_path name)) 205 | | Tcl_structure { cstr_fields = clfl;_ } -> 206 | from_classfields clfl 207 | | Tcl_fun (_,_,_,c_exp,_) -> 208 | make_exp_class c_exp 209 | | Tcl_apply (c_exp,_) -> 210 | make_exp_class c_exp 211 | | Tcl_constraint (c_exp,_,_,_,_) -> 212 | make_exp_class c_exp 213 | | Tcl_let (_,_,_,c_exp) -> 214 | make_exp_class c_exp 215 | 216 | (* set from class_declaration_list *) 217 | let make_pp_class_set class_decl_list ret = 218 | let rec from_list acc = function 219 | | [] -> List.rev acc 220 | | ({ ci_virt = Concrete; ci_id_name = {txt=cname;_}; ci_expr = c_expr; ci_params = params;_ },_)::xs -> 221 | let expression = fun_exp (make_exp_class c_expr) params in 222 | let vb = make_vb cname expression in 223 | from_list (vb :: acc) xs 224 | | _::xs -> 225 | from_list acc xs 226 | in 227 | let vb_list = from_list [] class_decl_list in 228 | if vb_list = [] 229 | then ret 230 | else (make_Tstr_val vb_list) :: ret 231 | 232 | let make_pp_sig_class_set class_desc_list ret = 233 | let rec from_list acc = function 234 | | [] -> List.rev acc 235 | | { ci_virt = Concrete; ci_id_name = {txt=cname;_}; ci_params = params;_ }::xs -> 236 | let sig_ = make_Tsig_val ("_pp_"^cname) (set_ps cname params) in 237 | from_list (sig_ :: acc) xs 238 | | _::xs -> 239 | from_list acc xs 240 | in 241 | let sigl = from_list [] class_desc_list in 242 | sigl @ ret 243 | -------------------------------------------------------------------------------- /helper.ml: -------------------------------------------------------------------------------- 1 | module SSet = Set.Make(struct 2 | type t = string 3 | let compare = compare 4 | end) 5 | 6 | open Asttypes 7 | open Format 8 | open Types 9 | open Typedtree 10 | open Longident 11 | open Ident 12 | 13 | (* ppopen check *) 14 | let ppopen = ref SSet.empty 15 | 16 | (* case_list table for type_extension & poly variant *) 17 | let caselist_tbl = ( Hashtbl.create 20 : (string,Typedtree.case list) Hashtbl.t ) 18 | 19 | (* polymorphic variant's params tbl *) 20 | let params_tbl = ( Hashtbl.create 20 : (string,(core_type * variance) list) Hashtbl.t ) 21 | 22 | (* 23 | * Types 24 | *) 25 | (* empty type_expr creator *) 26 | let type_none = {desc=Tnil;level=0;id=0} 27 | 28 | (* 29 | * Path 30 | *) 31 | (* Path.Pident creator from string *) 32 | let path_ident_create s = Path.Pident (Ident.create s) 33 | 34 | (* type path to pp path *) 35 | let rec path_set = function 36 | | Path.Pident {name = s;_} -> Path.Pident (Ident.create ("_pp_"^s)) 37 | | Path.Pdot (t,s,i) -> Path.Pdot (t,"_pp_"^s,i) 38 | | Path.Papply (t1,t2) -> Path.Papply (t1,path_set t2) 39 | 40 | (* 41 | * Longident 42 | *) 43 | (* path to Longident *) 44 | let rec path_to_longident = function 45 | | Path.Pident {name=s;_} -> Lident s 46 | | Path.Pdot (t,s,_) -> Ldot (path_to_longident t,s) 47 | | Path.Papply (t1,t2) -> Lapply (path_to_longident t1,path_to_longident t2) 48 | 49 | (* Longident to path *) 50 | let rec longident_to_path = function 51 | | Lident s -> path_ident_create s 52 | | Ldot (t,s) -> Path.Pdot (longident_to_path t,s,0) 53 | | Lapply (t1,t2) -> Path.Papply (longident_to_path t1,longident_to_path t2) 54 | 55 | (* Longident first *) 56 | let rec first = function 57 | | Lident s -> s 58 | | Ldot (t,s) -> first t 59 | | Lapply (t1,t2) -> first t1 60 | 61 | (* Longident last *) 62 | let last = last 63 | 64 | let rec l_to_s = function 65 | | Lident s -> s 66 | | Ldot (t,s) -> (l_to_s t) ^ "." ^ s 67 | | Lapply (t1,t2) -> (l_to_s t1) ^ " " ^ (l_to_s t2) 68 | 69 | (* 70 | * constructor_description 71 | *) 72 | let cstr_desc = 73 | { cstr_name = ""; 74 | cstr_res = type_none; 75 | cstr_existentials = []; 76 | cstr_args = []; 77 | cstr_arity = 0; 78 | cstr_tag = Cstr_constant 0; 79 | cstr_consts = 0; 80 | cstr_nonconsts = 0; 81 | cstr_normal = 0; 82 | cstr_generalized = false; 83 | cstr_private = Public; 84 | cstr_loc = Location.none; 85 | cstr_attributes = []; 86 | cstr_inlined = None; 87 | } 88 | 89 | (* 90 | * Structure_item 91 | *) 92 | let make_Tstr_val vb_list = 93 | { str_desc = 94 | Tstr_value (Recursive,vb_list); 95 | str_loc = Location.none; 96 | str_env = Env.empty} 97 | 98 | (* 99 | * Signature_item 100 | *) 101 | let make_Tsig_val name ctyp = 102 | { sig_desc = 103 | Tsig_value { val_id = Ident.create name; 104 | val_name = {txt=name;loc=Location.none}; 105 | val_desc = ctyp; 106 | val_val = { val_type = type_none; 107 | val_kind = Val_reg; 108 | val_loc = Location.none; 109 | val_attributes = [] }; 110 | val_prim = []; 111 | val_loc = Location.none; 112 | val_attributes = [] }; 113 | sig_loc = Location.none; 114 | sig_env = Env.empty} 115 | 116 | (* 117 | * Pattern 118 | *) 119 | (* Tpat_any creator *) 120 | let make_Tpat_any = 121 | { pat_desc = Tpat_any; 122 | pat_loc = Location.none; 123 | pat_extra = []; 124 | pat_type = type_none; 125 | pat_env = Env.empty; 126 | pat_attributes = [] 127 | } 128 | 129 | (* Tpat_var creator *) 130 | let make_Tpat_var name = 131 | { pat_desc = Tpat_var (Ident.create name,{txt=name;loc=Location.none}); 132 | pat_loc = Location.none; 133 | pat_extra = []; 134 | pat_type = type_none; 135 | pat_env = Env.empty; 136 | pat_attributes = [] 137 | } 138 | 139 | (* Tpat_tuple creator *) 140 | let make_Tpat_tuple pat_list = 141 | { pat_desc = Tpat_tuple pat_list; 142 | pat_loc = Location.none; 143 | pat_extra = []; 144 | pat_type = type_none; 145 | pat_env = Env.empty; 146 | pat_attributes = [] 147 | } 148 | 149 | (* Tpat_alias creator *) 150 | let make_Tpat_alias pat name = 151 | { pat_desc = Tpat_alias (pat,Ident.create name,{txt=name;loc=Location.none}); 152 | pat_loc = Location.none; 153 | pat_extra = []; 154 | pat_type = type_none; 155 | pat_env = Env.empty; 156 | pat_attributes = [] 157 | } 158 | 159 | (* Tpat_construct creator *) 160 | let make_Tpat_construct longident pat_list = 161 | { pat_desc = Tpat_construct ({txt=longident;loc=Location.none},cstr_desc,pat_list); 162 | pat_loc = Location.none; 163 | pat_extra = []; 164 | pat_type = type_none; 165 | pat_env = Env.empty; 166 | pat_attributes = [] 167 | } 168 | 169 | (* Tpat_variant creator *) 170 | let rd_none = 171 | { row_fields = []; 172 | row_more = type_none; 173 | row_bound = (); 174 | row_closed = true; 175 | row_fixed = false; 176 | row_name = None } 177 | 178 | let make_Tpat_variant label ?(rd=rd_none) pat_opt = 179 | { pat_desc = Tpat_variant (label,pat_opt,ref rd); 180 | pat_loc = Location.none; 181 | pat_extra = []; 182 | pat_type = type_none; 183 | pat_env = Env.empty; 184 | pat_attributes = [] 185 | } 186 | 187 | (* 188 | * Expression 189 | *) 190 | (* Texp_construct creator *) 191 | let make_Texp_construct longident expr_list = 192 | { exp_desc = Texp_construct ({txt=longident;loc=Location.none},cstr_desc,expr_list); 193 | exp_loc = Location.none; 194 | exp_extra = []; 195 | exp_type = type_none; 196 | exp_env = Env.empty; 197 | exp_attributes = [] 198 | } 199 | 200 | (* Texp_constant creator *) 201 | let make_Texp_constant const = 202 | { exp_desc = Texp_constant const; 203 | exp_loc = Location.none; 204 | exp_extra = []; 205 | exp_type = type_none; 206 | exp_env = Env.empty; 207 | exp_attributes = [] 208 | } 209 | 210 | (* Texp_tuple creator *) 211 | let make_Texp_tuple elist = 212 | { exp_desc = Texp_tuple elist; 213 | exp_loc = Location.none; 214 | exp_extra = []; 215 | exp_type = type_none; 216 | exp_env = Env.empty; 217 | exp_attributes = [] 218 | } 219 | 220 | (* Texp_ident creator *) 221 | let make_Texp_ident ?(typ=type_none) path = 222 | { exp_desc = Texp_ident (path, 223 | {txt = path_to_longident path; 224 | loc = Location.none}, 225 | {val_type = typ; 226 | val_kind=Val_reg; 227 | val_loc=Location.none; 228 | val_attributes=[]}); 229 | exp_loc = Location.none; 230 | exp_extra = []; 231 | exp_type = type_none; 232 | exp_env = Env.empty; 233 | exp_attributes = [] 234 | } 235 | 236 | (* Texp_field creator *) 237 | let make_Texp_field exp longident = 238 | let ld = 239 | { lbl_name = ""; 240 | lbl_res = type_none; 241 | lbl_arg = type_none; 242 | lbl_mut = Mutable; 243 | lbl_pos = 0; 244 | lbl_all = [||]; 245 | lbl_repres = Record_regular; 246 | lbl_private = Private; 247 | lbl_loc = Location.none; 248 | lbl_attributes = []} 249 | in 250 | { exp_desc = 251 | Texp_field (exp,{txt=longident;loc=Location.none},ld); 252 | exp_loc = Location.none; 253 | exp_extra = []; 254 | exp_type = type_none; 255 | exp_env = Env.empty; 256 | exp_attributes = [] 257 | } 258 | 259 | (* Texp_apply creator *) 260 | let make_Texp_apply expr1 arg_list = 261 | { exp_desc = 262 | Texp_apply (expr1,arg_list); 263 | exp_loc = Location.none; 264 | exp_extra = []; 265 | exp_type = type_none; 266 | exp_env = Env.empty; 267 | exp_attributes = [] 268 | } 269 | 270 | (* Texp_function creator *) 271 | let make_Texp_function case_list = 272 | { exp_desc = 273 | Texp_function (Nolabel,case_list,Total); 274 | exp_loc = Location.none; 275 | exp_extra = []; 276 | exp_type = type_none; 277 | exp_env = Env.empty; 278 | exp_attributes = [] 279 | } 280 | 281 | (* Texp_function single creator *) 282 | let make_Texp_fun name e = 283 | make_Texp_function 284 | [{ c_lhs = {pat_desc = 285 | Tpat_var ((Ident.create name), 286 | {txt=name;loc=Location.none}); 287 | pat_loc = Location.none; 288 | pat_extra = []; 289 | pat_type = type_none; 290 | pat_env = Env.empty; 291 | pat_attributes = []}; 292 | c_guard = None; 293 | c_rhs = e}] 294 | 295 | (* Texp_sequence creator *) 296 | let make_Texp_sequence e1 e2 = 297 | { exp_desc = 298 | Texp_sequence (e1,e2); 299 | exp_loc = Location.none; 300 | exp_extra = []; 301 | exp_type = type_none; 302 | exp_env = Env.empty; 303 | exp_attributes = [] 304 | } 305 | 306 | (* Texp_let creator *) 307 | let make_Texp_let flag vbl e = 308 | { exp_desc = 309 | Texp_let (flag,vbl,e); 310 | exp_loc = Location.none; 311 | exp_extra = []; 312 | exp_type = type_none; 313 | exp_env = Env.empty; 314 | exp_attributes = [] 315 | } 316 | 317 | (* 318 | * core_type 319 | * *) 320 | let make_Cty_var s = 321 | { ctyp_desc = Ttyp_var s; 322 | ctyp_type = type_none; 323 | ctyp_env = Env.empty; 324 | ctyp_loc = Location.none; 325 | ctyp_attributes = [] } 326 | 327 | let make_Cty_constr longident ctyl = 328 | { ctyp_desc = Ttyp_constr (longident_to_path longident,{txt=longident;loc=Location.none},ctyl); 329 | ctyp_type = type_none; 330 | ctyp_env = Env.empty; 331 | ctyp_loc = Location.none; 332 | ctyp_attributes = [] } 333 | 334 | let make_Cty_arrow label x y = 335 | { ctyp_desc = Ttyp_arrow (label,x,y); 336 | ctyp_type = type_none; 337 | ctyp_env = Env.empty; 338 | ctyp_loc = Location.none; 339 | ctyp_attributes = [] } 340 | 341 | let set_ps name params = 342 | let ps = List.map fst params in 343 | let cty_fmt = make_Cty_constr (Ldot (Lident "Format","formatter")) [] in 344 | let cty_x = make_Cty_constr (Lident name) ps in 345 | let cty_u = make_Cty_constr (Lident "unit") [] in 346 | let nl = Asttypes.Nolabel in 347 | let cty_arr2 a b c = make_Cty_arrow nl a (make_Cty_arrow nl b c) in 348 | let rec ret x = 349 | match x.ctyp_desc with 350 | | Ttyp_arrow _ -> 351 | make_Cty_arrow 352 | nl 353 | cty_fmt 354 | (make_Cty_constr (Lident "string") []) 355 | | Ttyp_tuple xs -> 356 | let rec from_list = function 357 | | [] -> cty_arr2 cty_fmt x cty_u 358 | | x::xs -> 359 | make_Cty_arrow nl (ret x) (from_list xs) 360 | in 361 | from_list xs 362 | | Ttyp_constr (_,{txt=li;_},tyl) -> 363 | let rec from_list = function 364 | | [] -> cty_arr2 cty_fmt x cty_u 365 | | x::xs -> 366 | make_Cty_arrow nl (ret x) (from_list xs) 367 | in 368 | from_list tyl 369 | | Ttyp_class (_,{txt=li;_},tyl) -> 370 | let rec from_list = function 371 | | [] -> cty_arr2 cty_fmt x cty_u 372 | | x::xs -> 373 | make_Cty_arrow nl (ret x) (from_list xs) 374 | in 375 | from_list tyl 376 | | _ -> cty_arr2 cty_fmt x cty_u 377 | in 378 | let rec from_list = function 379 | | [] -> cty_arr2 cty_fmt cty_x cty_u 380 | | x::xs -> 381 | make_Cty_arrow nl (ret x) (from_list xs) 382 | in 383 | from_list ps 384 | 385 | (* expr of std_formatter *) 386 | let expr_std_formatter = 387 | make_Texp_ident (Path.Pdot (Path.Pident (Ident.create "Format"),"std_formatter",0)) 388 | 389 | (* For alias (as) loop *) 390 | let pre = ref SSet.empty 391 | 392 | (* select pp from type_expr *) 393 | let rec select_pp typ = 394 | let typelist_to_arglist typelist = 395 | let rec from_list acc = function 396 | | [] -> List.rev acc 397 | | x::xs -> 398 | from_list ((Nolabel,Some (select_pp x)) :: acc) xs 399 | in 400 | from_list [] typelist 401 | in 402 | let from_row_desc ({ row_fields = rf_list;row_more = more;_ } as rd) = 403 | let rec make_caselist_from_rflist acc = function 404 | | [] -> List.rev acc 405 | | (cons,Rpresent None)::xs -> 406 | make_caselist_from_rflist 407 | ({ c_lhs = make_Tpat_variant cons None ~rd:rd; 408 | c_guard = None; 409 | c_rhs = make_Texp_tuple 410 | [make_Texp_constant (Const_string ("`"^cons,None)); 411 | make_cps_expr 1 []] } :: acc) 412 | xs 413 | | (cons,Rpresent (Some ty_expr))::xs -> 414 | make_caselist_from_rflist 415 | ({ c_lhs = make_Tpat_variant cons (Some (List.hd (pat_list 1))) ~rd:rd; 416 | c_guard = None; 417 | c_rhs = make_Texp_tuple 418 | [make_Texp_constant (Const_string ("`"^cons,None)); 419 | make_cps_expr 1 [ty_expr]] } :: acc) 420 | xs 421 | | (cons,Reither (_,tyl,_,_))::xs -> 422 | make_caselist_from_rflist 423 | ({ c_lhs = make_Tpat_variant cons (Some (List.hd (pat_list 1))) ~rd:rd; 424 | c_guard = None; 425 | c_rhs = make_Texp_tuple 426 | [make_Texp_constant (Const_string ("`"^cons,None)); 427 | make_cps_expr 1 tyl]} :: acc) 428 | xs 429 | | (cons,Rabsent)::xs -> 430 | failwith "TODO: Types.Rabsent" 431 | in 432 | let case_list = make_caselist_from_rflist [] rf_list in 433 | (make_Texp_apply 434 | (make_Texp_ident (path_ident_create "_pp__variant")) 435 | [Nolabel,Some (make_Texp_function case_list)]) 436 | in 437 | let rec from_tfields ty = 438 | match ty.desc with 439 | | Tnil -> make_Texp_construct (Lident "[]") [] 440 | | Tfield (name,_,mty,rest) -> 441 | let ty_s = Format.asprintf "%a" Printtyp.type_expr mty in 442 | make_Texp_construct 443 | (Lident "::") 444 | [make_Texp_tuple 445 | [make_Texp_constant (Const_string (name,None)); 446 | make_Texp_apply 447 | (make_Texp_apply 448 | (make_Texp_ident (path_ident_create "!%")) 449 | [Nolabel,Some (make_Texp_apply 450 | (make_Texp_ident (path_ident_create "_pp__dump")) 451 | [Nolabel,Some (make_Texp_constant (Const_string (ty_s,None)))])]) 452 | [Nolabel,Some (make_Texp_construct (Lident "()") [])]]; 453 | from_tfields rest] 454 | | _ -> failwith "TODO: from_tfields" 455 | in 456 | match typ.desc with 457 | | Tvar None -> 458 | make_Texp_ident (path_ident_create "_pp__unsup") ~typ:typ 459 | | Tvar (Some s) -> 460 | make_Texp_ident (path_ident_create ("_arg_"^s)) ~typ:typ 461 | | Tarrow _ -> 462 | let type_str = Format.asprintf "%a" Printtyp.type_expr typ in 463 | make_Texp_apply (make_Texp_ident (path_ident_create ("_pp__function"))) 464 | [Nolabel,Some (make_Texp_constant (Const_string (type_str,None)))] 465 | | Ttuple typelist -> 466 | let len = List.length typelist in 467 | if len < 2 || len > 7 468 | then make_Texp_apply (make_Texp_ident (path_ident_create ("_pp__dump"))) 469 | [Nolabel,Some (make_Texp_constant (Const_string ("< "^string_of_int len^" elements tuple >",None)))] 470 | else make_Texp_apply (make_Texp_ident (path_ident_create ("_pp__tuple"^string_of_int len))) 471 | (typelist_to_arglist typelist) 472 | | Tconstr (Path.Pident {name=s;_},[],_) -> 473 | make_Texp_ident (path_ident_create ("_pp_"^s)) ~typ:typ 474 | | Tconstr (Path.Pident {name=s;_},typelist,_) -> 475 | make_Texp_apply (make_Texp_ident (path_ident_create ("_pp_"^s)) ~typ:typ) (typelist_to_arglist typelist) 476 | | Tconstr (path,[],_) -> 477 | begin match Path.name path with 478 | | "Pervasives.in_channel" 479 | | "Pervasives.out_channel" 480 | | "Pervasives.fpclass" 481 | | "Pervasives.open_flag" -> 482 | make_Texp_ident (path_ident_create ("_pp_"^Path.last path)) ~typ:typ 483 | | _ -> let m = first (path_to_longident path) in 484 | if SSet.mem m !ppopen 485 | then make_Texp_ident (path_set path) ~typ:typ 486 | else make_Texp_apply (make_Texp_ident (path_ident_create "_pp__dump") ~typ:typ) 487 | [Nolabel,Some (make_Texp_constant 488 | (Const_string ("< "^m^"'s type without OCaml@p >",None)))] 489 | end 490 | | Tconstr (path,typelist,_) -> 491 | begin match Path.name path with 492 | | "Pervasives.format6" 493 | | "Pervasives.format4" 494 | | "Pervasives.format" -> 495 | make_Texp_ident (path_ident_create ("_pp_"^Path.last path)) ~typ:typ 496 | | "Pervasives.ref" -> 497 | make_Texp_apply (make_Texp_ident (path_ident_create ("_pp_"^Path.last path)) ~typ:typ) (typelist_to_arglist typelist) 498 | | _ -> let m = first (path_to_longident path) in 499 | if SSet.mem m !ppopen 500 | then make_Texp_apply (make_Texp_ident (path_set path) ~typ:typ) (typelist_to_arglist typelist) 501 | else make_Texp_apply (make_Texp_ident (path_ident_create "_pp__dump") ~typ:typ) 502 | [Nolabel,Some (make_Texp_constant 503 | (Const_string ("< "^m^"'s type without OCaml@p >",None)))] 504 | 505 | end 506 | | Tobject (ty,ref) -> 507 | begin match !ref with 508 | | Some _ (* TODO *) 509 | | None -> 510 | let expression = from_tfields ty in 511 | let case_list = 512 | [{ c_lhs = make_Tpat_any; 513 | c_guard = None; 514 | c_rhs = expression }] 515 | in 516 | make_Texp_apply (make_Texp_ident (path_ident_create "_pp__object")) 517 | [Nolabel,Some (make_Texp_function case_list)] 518 | end 519 | | Tfield _ -> failwith "not use" 520 | | Tnil -> 521 | make_Texp_ident (path_ident_create "_pp__nouse") ~typ:typ 522 | | Tlink ty -> select_pp ty 523 | | Tsubst _ -> failwith "TODO: Tsubst" 524 | | Tvariant row_desc -> 525 | from_row_desc row_desc 526 | | Tunivar _ -> failwith "TODO: Tunivar" 527 | | Tpoly (ty,_) -> 528 | (* TODO *) 529 | select_pp ty 530 | | Tpackage _ -> failwith "TODO: Tpackage" 531 | 532 | (* select pp from core_type *) 533 | (* 534 | and select_pp_core {ctyp_type = type_expr;_} = select_pp type_expr 535 | *) 536 | 537 | and select_pp_core ?(ty_name="") cty = 538 | let typelist_to_arglist typelist = 539 | let rec from_list acc = function 540 | | [] -> List.rev acc 541 | | x::xs -> 542 | from_list ((Nolabel,Some (select_pp_core x)) :: acc) xs 543 | in 544 | from_list [] typelist 545 | in 546 | let rec make_caselist_obj acc_f = function 547 | | [] -> [{ c_lhs = make_Tpat_any; 548 | c_guard = None; 549 | c_rhs = acc_f (make_Texp_construct (Lident "[]") [] )}] 550 | | (name,_,cty)::xs -> 551 | let type_s = Format.asprintf "%a" Printtyp.type_expr cty.ctyp_type in 552 | make_caselist_obj 553 | (fun inter -> 554 | acc_f 555 | (make_Texp_construct 556 | (Lident "::") 557 | [make_Texp_tuple 558 | [make_Texp_constant (Const_string (name,None)); 559 | make_Texp_apply 560 | (make_Texp_apply 561 | (make_Texp_ident (path_ident_create "!%")) 562 | [Nolabel,Some (make_Texp_apply 563 | (make_Texp_ident (path_ident_create "_pp__dump")) 564 | [Nolabel,Some (make_Texp_constant (Const_string (type_s,None)))])]) 565 | [Nolabel,Some (make_Texp_construct (Lident "()") [])]]; 566 | inter])) 567 | xs 568 | in 569 | let rec arg_select_pp_ctyl acc = function 570 | | [] -> List.rev acc 571 | | x::xs -> 572 | arg_select_pp_ctyl 573 | ((Nolabel,Some (select_pp_core x)) :: acc) 574 | xs 575 | in 576 | let rev_app params ctyl ori b = 577 | let rec loop a = function 578 | | [] -> a 579 | | ({c_rhs = e;_} as x)::xs -> 580 | if (List.length params) = 0 581 | then 582 | loop (x::a) xs 583 | else 584 | loop 585 | ({x with c_rhs = make_Texp_apply 586 | (fun_exp ~prfx:false e params) 587 | (arg_select_pp_ctyl [] ctyl); } :: a) 588 | xs 589 | in 590 | loop ori b 591 | in 592 | let rec make_caselist_var acc = function 593 | | [] -> List.rev acc 594 | | (Ttag (const,_,_,ctyl))::xs -> 595 | let len = List.length ctyl in 596 | let arg = 597 | match len with 598 | | 0 -> None 599 | | 1 -> Some (List.hd (pat_list len)) 600 | | _ -> Some (make_Tpat_tuple (pat_list len)) 601 | in 602 | make_caselist_var 603 | ({ c_lhs = make_Tpat_variant const arg; 604 | c_guard = None; 605 | c_rhs = make_Texp_tuple 606 | [make_Texp_constant (Const_string ("`"^const,None)); 607 | make_cps_expr_cty 1 ctyl]} :: acc) 608 | xs 609 | | (Tinherit {ctyp_desc = Ttyp_constr(Path.Pident {name=s;_},_,ctyl);})::xs -> 610 | let inh_cl = Hashtbl.find caselist_tbl s in 611 | let params = Hashtbl.find params_tbl s in 612 | make_caselist_var (rev_app params ctyl acc inh_cl) xs 613 | | _ -> failwith "Inheritance from other file isn't unsupported." 614 | in 615 | (* 616 | let check_params_alias ty_name s = 617 | let rec loop = function 618 | | [] -> false 619 | | ({ctyp_desc = Ttyp_var name;_},_)::xs -> 620 | if name = s 621 | then true 622 | else loop xs 623 | | _::xs -> loop xs 624 | in 625 | try 626 | let ls = Hashtbl.find params_tbl ty_name in 627 | loop ls 628 | with _ -> false 629 | in 630 | *) 631 | match cty.ctyp_desc with 632 | | Ttyp_any -> 633 | make_Texp_ident (path_ident_create "_pp__unsup") ~typ:cty.ctyp_type 634 | | Ttyp_var s -> 635 | make_Texp_ident (path_ident_create ("_arg_"^s)) ~typ:cty.ctyp_type 636 | | Ttyp_arrow _ -> 637 | let type_str = Format.asprintf "%a" Printtyp.type_expr cty.ctyp_type in 638 | make_Texp_apply (make_Texp_ident (path_ident_create ("_pp__function"))) 639 | [Nolabel,Some (make_Texp_constant (Const_string (type_str,None)))] 640 | | Ttyp_tuple ctyl -> 641 | let len = List.length ctyl in 642 | if len < 2 || len > 7 643 | then make_Texp_apply (make_Texp_ident (path_ident_create ("_pp__dump"))) 644 | [Nolabel,Some (make_Texp_constant (Const_string ("< "^string_of_int len^" elements tuple >",None)))] 645 | else make_Texp_apply (make_Texp_ident (path_ident_create ("_pp__tuple"^string_of_int len))) 646 | (typelist_to_arglist ctyl) 647 | | Ttyp_constr (Path.Pident {name=s;_},_,[]) -> 648 | make_Texp_ident (path_ident_create ("_pp_"^s)) ~typ:cty.ctyp_type 649 | | Ttyp_constr (Path.Pident {name=s;_},_,typelist) -> 650 | make_Texp_apply (make_Texp_ident (path_ident_create ("_pp_"^s)) ~typ:cty.ctyp_type) (typelist_to_arglist typelist) 651 | | Ttyp_constr (path,_,[]) -> 652 | begin match Path.name path with 653 | | "Pervasives.in_channel" 654 | | "Pervasives.out_channel" 655 | | "Pervasives.fpclass" 656 | | "Pervasives.open_flag" -> 657 | make_Texp_ident (path_ident_create ("_pp_"^Path.last path)) ~typ:cty.ctyp_type 658 | | _ -> let m = first (path_to_longident path) in 659 | if SSet.mem m !ppopen 660 | then make_Texp_ident (path_set path) ~typ:cty.ctyp_type 661 | else make_Texp_apply (make_Texp_ident (path_ident_create "_pp__dump") ~typ:cty.ctyp_type) 662 | [Nolabel,Some (make_Texp_constant 663 | (Const_string ("< "^m^"'s type without OCaml@p >",None)))] 664 | end 665 | | Ttyp_constr (path,_,typelist) -> 666 | begin match Path.name path with 667 | | "Pervasives.format6" 668 | | "Pervasives.format4" 669 | | "Pervasives.format" -> 670 | make_Texp_ident (path_ident_create ("_pp_"^Path.last path)) ~typ:cty.ctyp_type 671 | | "Pervasives.ref" -> 672 | make_Texp_apply (make_Texp_ident (path_ident_create ("_pp_"^Path.last path)) ~typ:cty.ctyp_type) (typelist_to_arglist typelist) 673 | | _ -> let m = first (path_to_longident path) in 674 | if SSet.mem m !ppopen 675 | then make_Texp_apply (make_Texp_ident (path_set path) ~typ:cty.ctyp_type) (typelist_to_arglist typelist) 676 | else make_Texp_apply (make_Texp_ident (path_ident_create "_pp__dump") ~typ:cty.ctyp_type) 677 | [Nolabel,Some (make_Texp_constant 678 | (Const_string ("< "^m^"'s type without OCaml@p >",None)))] 679 | 680 | end 681 | | Ttyp_object (str_att_cty_list,_) -> 682 | let case_list = make_caselist_obj (fun x -> x) str_att_cty_list in 683 | make_Texp_apply (make_Texp_ident (path_ident_create "_pp__object")) 684 | [Nolabel,Some (make_Texp_function case_list)] 685 | | Ttyp_class (path,_,typelist) -> 686 | let m = first (path_to_longident path) in 687 | if SSet.mem m !ppopen 688 | then make_Texp_apply (make_Texp_ident (path_set path) ~typ:cty.ctyp_type) (typelist_to_arglist typelist) 689 | else make_Texp_apply (make_Texp_ident (path_ident_create "_pp__dump") ~typ:cty.ctyp_type) 690 | [Nolabel,Some (make_Texp_constant 691 | (Const_string ("< "^m^"'s Type without OCaml@p >",None)))] 692 | | Ttyp_alias (ctyp,s) -> 693 | (* 694 | let c = check_params_alias ty_name s in 695 | if c 696 | then 697 | select_pp_core ctyp 698 | else 699 | *) 700 | (make_Texp_let 701 | Recursive 702 | [{ vb_pat = make_Tpat_var ("_arg_"^s); 703 | vb_expr = app_prfx (select_pp_core ctyp); 704 | vb_attributes = []; 705 | vb_loc = Location.none }] 706 | (make_Texp_ident (path_ident_create ("_arg_"^s)))) 707 | | Ttyp_variant (row_field_list,_,_) -> 708 | let case_list = make_caselist_var [] row_field_list in 709 | Hashtbl.add caselist_tbl ty_name case_list; 710 | make_Texp_apply (make_Texp_ident (path_ident_create "_pp__variant")) 711 | [Nolabel,Some (make_Texp_function case_list)] 712 | | Ttyp_poly (sl,ctyl) -> 713 | (* TODO *) 714 | select_pp cty.ctyp_type 715 | | Ttyp_package p -> 716 | (* TODO *) 717 | select_pp cty.ctyp_type 718 | 719 | (* 720 | * * prepare for variant pp 721 | * *) 722 | (* create constructor argument *) 723 | and pat_list n = 724 | let rec loop acc = function 725 | | 0 -> acc 726 | | n -> loop (make_Tpat_var ("_p"^string_of_int n)::acc) (n-1) 727 | in 728 | loop [] n 729 | 730 | (* create cps for ctyl *) 731 | and make_cps_expr_cty n = function 732 | | [] -> make_Texp_construct (Lident "[]") [] 733 | | x::xs -> 734 | make_Texp_construct 735 | (Lident "::") 736 | [make_Texp_apply 737 | (make_Texp_apply 738 | (make_Texp_ident (path_ident_create "!%")) 739 | [Nolabel,Some (select_pp_core x)]) 740 | [Nolabel,Some (make_Texp_ident (path_ident_create ("_p"^string_of_int n)))]; 741 | make_cps_expr_cty (n+1) xs] 742 | 743 | (* create cps for type_expl_list *) 744 | and make_cps_expr n = function 745 | | [] -> make_Texp_construct (Lident "[]") [] 746 | | x::xs -> 747 | make_Texp_construct 748 | (Lident "::") 749 | [make_Texp_apply 750 | (make_Texp_apply 751 | (make_Texp_ident (path_ident_create "!%")) 752 | [Nolabel,Some (select_pp x)]) 753 | [Nolabel,Some (make_Texp_ident (path_ident_create ("_p"^string_of_int n)))]; 754 | make_cps_expr (n+1) xs] 755 | 756 | and app_prfx exp = 757 | make_Texp_fun "_prf" 758 | (make_Texp_fun "_arg" 759 | (make_Texp_apply 760 | exp 761 | [Nolabel,Some (make_Texp_ident (path_ident_create "_prf")); 762 | Nolabel,Some (make_Texp_ident (path_ident_create "_arg"))])) 763 | 764 | (* core_type Ttyp_var to string *) 765 | and get_name ct = 766 | match ct.ctyp_desc with 767 | | Ttyp_var s -> s 768 | | _ -> failwith "Not reached" 769 | 770 | (* fun _pp_1 -> ... -> expr : expression -> (core_type * variance) list -> expression *) 771 | and fun_exp ?(prfx = true) exp ls = 772 | let rec loop acc = function 773 | | [] -> acc 774 | | x::xs -> 775 | let name = "_arg_" ^ get_name x in 776 | loop (make_Texp_fun name acc) xs 777 | in 778 | if prfx 779 | then loop (app_prfx exp) (List.rev (List.map fst ls)) 780 | else loop exp (List.rev (List.map fst ls)) 781 | 782 | (* create value_binding for pp *) 783 | let make_vb ty_name exp = 784 | {vb_pat = 785 | {pat_desc = Tpat_var (Ident.create ("_pp_"^ty_name), 786 | {txt="_pp_"^ty_name;loc=Location.none}); 787 | pat_loc = Location.none; 788 | pat_extra = []; 789 | pat_type = type_none; 790 | pat_env = Env.empty; 791 | pat_attributes = []}; 792 | vb_expr = exp; 793 | vb_attributes = []; 794 | vb_loc = Location.none} 795 | -------------------------------------------------------------------------------- /insert.ml: -------------------------------------------------------------------------------- 1 | open Asttypes 2 | open Typedtree 3 | open Helper 4 | open Longident 5 | 6 | (* _this expression *) 7 | let expr_this typ = 8 | { exp_desc = Texp_ident (Path.Pident (Ident.create "_this"), 9 | {txt = Lident "_this";loc = Location.none}, 10 | {Types.val_type = typ; 11 | Types.val_kind = Types.Val_reg; 12 | Types.val_loc = Location.none; 13 | Types.val_attributes = []}); 14 | exp_loc = Location.none; 15 | exp_extra = []; 16 | exp_type = typ; 17 | exp_env = Env.empty; 18 | exp_attributes = [] 19 | } 20 | 21 | (* actual insert function *) 22 | let insert_pp expr print_expr b extra = 23 | (* 24 | let rec check_extra = function 25 | | [] -> None 26 | | (Texp_constraint cty,_,_)::xs 27 | | (Texp_coerce (_,cty),_,_)::xs -> 28 | Some cty 29 | | _::xs -> 30 | check_extra xs 31 | in 32 | *) 33 | let expr_newline = 34 | if b 35 | then 36 | { exp_desc = 37 | Texp_sequence 38 | ({ exp_desc = 39 | Texp_apply (make_Texp_ident (path_ident_create "_pp_newline"), 40 | [(Nolabel,Some expr_std_formatter); 41 | (Nolabel,Some (make_Texp_construct (Lident "()") []))]); 42 | exp_loc = Location.none; 43 | exp_extra = []; 44 | exp_type = type_none; 45 | exp_env = expr.exp_env; 46 | exp_attributes = [] 47 | }, 48 | expr); 49 | exp_loc = Location.none; 50 | exp_extra = []; 51 | exp_type = expr.exp_type; 52 | exp_env = expr.exp_env; 53 | exp_attributes = [] 54 | } 55 | else expr 56 | in 57 | let expr_pp pp = 58 | { exp_desc = 59 | Texp_sequence 60 | ({ exp_desc = 61 | Texp_apply (pp, 62 | [Nolabel,Some expr_std_formatter;Nolabel,Some print_expr]); 63 | exp_loc = Location.none; 64 | exp_extra = []; 65 | exp_type = type_none; 66 | exp_env = expr.exp_env; 67 | exp_attributes = [] 68 | }, 69 | expr_newline); 70 | exp_loc = Location.none; 71 | exp_extra = []; 72 | exp_type = expr.exp_type; 73 | exp_env = expr.exp_env; 74 | exp_attributes = [] 75 | } 76 | in 77 | let pp = 78 | (* 79 | match check_extra extra with 80 | | None -> 81 | *) 82 | select_pp print_expr.exp_type 83 | (* 84 | | Some cty -> 85 | select_pp_core cty 86 | *) 87 | in 88 | expr_pp pp 89 | -------------------------------------------------------------------------------- /mod.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | open Typedtree 3 | open Asttypes 4 | open Helper 5 | open Insert 6 | open Create 7 | open Longident 8 | 9 | module MapArg : TypedtreeMap.MapArgument = struct 10 | include TypedtreeMap.DefaultMapArgument 11 | 12 | (* 13 | * let式のpatternへのマーカ検出 14 | * 15 | * 1つ以上あると1回だけ出力 16 | *) 17 | let rec check_attr a1 a2 = function 18 | | [] -> (a1,List.rev a2) 19 | | ({txt="p";_},_)::xs -> check_attr true a2 xs 20 | | x::xs -> check_attr a1 (x::a2) xs 21 | 22 | let rec check_pat acc = function 23 | | [] -> List.rev acc 24 | | ({vb_pat=pat;vb_expr=e;_} as vb)::xs -> 25 | let (check,cut) = check_attr false [] pat.pat_attributes in 26 | if check 27 | then 28 | let p = {pat with pat_attributes = cut} in 29 | let pat_str = 30 | Format.asprintf 31 | "%a = " 32 | Pprintast.pattern 33 | (Untypeast.(default_mapper.pat default_mapper p)) 34 | in 35 | let ms = 36 | let open Ast_helper in 37 | let open Parsetree in 38 | ({txt="ps";loc=Location.none}, 39 | (PStr [Str.eval (Exp.constant (Pconst_string (pat_str,None)))])) 40 | in 41 | let mp = ({txt="p";loc=Location.none},Parsetree.PStr []) in 42 | let new_vb = 43 | {vb with vb_pat = p; 44 | vb_expr = 45 | {e with exp_attributes = ms :: mp :: e.exp_attributes}} in 46 | check_pat (new_vb :: acc) xs 47 | else check_pat (vb :: acc) xs 48 | 49 | (* 50 | * expression mapper 51 | * *) 52 | let enter_expression expr = 53 | let this_i = Ident.create "_this" in 54 | let value_d expr = 55 | Types.{ val_type = expr.exp_type; 56 | val_kind = Val_reg; 57 | val_loc = Location.none; 58 | val_attributes = [] 59 | } 60 | in 61 | let rec pickup_attr expr extra = function 62 | | [] -> expr_this expr.exp_type 63 | (* print argument with newline *) 64 | | ({txt = "p";_},Parsetree.PStr [{Parsetree.pstr_desc=Parsetree.Pstr_eval (print_ast_expr,_);_}])::xs -> 65 | insert_pp (pickup_attr expr extra xs) (Typecore.type_expression Env.(add_value this_i (value_d expr) expr.exp_env) print_ast_expr) true extra 66 | (* print expression with newline *) 67 | | ({txt = "p";_},Parsetree.PStr [])::xs -> 68 | insert_pp (pickup_attr expr extra xs) (expr_this expr.exp_type) true extra 69 | (* print argument *) 70 | | ({txt = "ps";_},Parsetree.PStr [{Parsetree.pstr_desc=Parsetree.Pstr_eval (print_ast_expr,_);_}])::xs -> 71 | insert_pp (pickup_attr expr extra xs) (Typecore.type_expression Env.(add_value this_i (value_d expr) expr.exp_env) print_ast_expr) false extra 72 | (* print expression *) 73 | | ({txt = "ps";_},Parsetree.PStr [])::xs -> 74 | insert_pp (pickup_attr expr extra xs) (expr_this expr.exp_type) false extra 75 | (* other attributes *) 76 | | _::xs -> pickup_attr expr extra xs 77 | in 78 | let mk_exp attr extra expr = 79 | { exp_desc = 80 | Texp_let 81 | (Nonrecursive, 82 | [{ vb_pat = { pat_desc = Tpat_var (Ident.create "_this",{txt = "_this";loc = Location.none}); 83 | pat_loc = Location.none; 84 | pat_extra = []; 85 | pat_type = expr.exp_type; 86 | pat_env = Env.empty; 87 | pat_attributes = []; 88 | }; 89 | vb_expr = { expr with exp_attributes = [];exp_extra = extra }; 90 | vb_attributes = []; 91 | vb_loc = Location.none; 92 | }], 93 | pickup_attr expr extra attr); 94 | exp_loc = Location.none; 95 | exp_extra = []; 96 | exp_type = expr.exp_type; 97 | exp_env = expr.exp_env; 98 | exp_attributes = [] 99 | } 100 | in 101 | let check_extra ls = 102 | let rec loop acc1 acc2 = function 103 | | [] -> (acc1,List.rev acc2) 104 | | (t1,t2,x)::xs -> 105 | if List.length x = 0 106 | then loop acc1 ((t1,t2,x)::acc2) xs 107 | else loop (x @ acc1) ((t1,t2,[])::acc2) xs 108 | in 109 | loop [] [] ls 110 | in 111 | let pat_checked_expr = 112 | match expr.exp_desc with 113 | | Texp_let (f,vblist,e) -> 114 | let new_vblist = check_pat [] vblist in 115 | { expr with exp_desc = Texp_let (f,new_vblist,e) } 116 | | _ -> expr 117 | in 118 | let (extra_attr,extra) = check_extra pat_checked_expr.exp_extra in 119 | if List.length pat_checked_expr.exp_attributes = 0 120 | then 121 | (if List.length extra_attr = 0 122 | then pat_checked_expr 123 | else mk_exp extra_attr extra pat_checked_expr) 124 | else mk_exp (expr.exp_attributes @ extra_attr) extra pat_checked_expr 125 | 126 | (* 127 | * structure_item mapper 128 | * *) 129 | let enter_structure structure = 130 | let rec select_str_item acc = function 131 | | [] -> List.rev acc 132 | (* declaration let *) 133 | | ({str_desc = Tstr_value (flag,vblist);_} as str_item)::xs -> 134 | let new_vblist = check_pat [] vblist in 135 | select_str_item ({ str_item with str_desc = Tstr_value (flag,new_vblist) }::acc) xs 136 | (* variant, record, type_extension open, poly variant*) 137 | | ({str_desc = Tstr_type (_,type_decl_list);_} as str_item)::xs -> 138 | select_str_item (make_pp_type_set type_decl_list (str_item :: acc)) xs 139 | (* type_extension extend *) 140 | | ({str_desc = Tstr_typext (type_ext);_} as str_item)::xs -> 141 | select_str_item (make_pp_type_ext type_ext (str_item :: acc)) xs 142 | (* class *) 143 | | ({str_desc = Tstr_class cdslist;_} as str_item)::xs -> 144 | select_str_item (make_pp_class_set cdslist (str_item :: acc)) xs 145 | (* ppopen *) 146 | | {str_desc = 147 | Tstr_attribute 148 | ({txt="ppopen";_}, 149 | Parsetree.PStr ([{Parsetree.pstr_desc = 150 | Parsetree.Pstr_eval ({Parsetree.pexp_desc=Parsetree.Pexp_construct ({txt = Lident name;_},_);_},_);_}]) 151 | )}::xs -> 152 | ppopen := SSet.add name !ppopen; 153 | select_str_item acc xs 154 | (* module ppopen *) 155 | | ({str_desc = Tstr_module ({mb_name = {txt=name;_}; mb_expr = me;_} as mb);_} as str_item)::xs -> 156 | ppopen := SSet.add name !ppopen; 157 | select_str_item ({str_item with str_desc = Tstr_module {mb with mb_expr = enter_module_expr me}} :: acc) xs 158 | | x::xs -> select_str_item ((enter_structure_item x)::acc) xs 159 | in 160 | { structure with str_items = (select_str_item [] structure.str_items) } 161 | 162 | (* 163 | * structure_item mapper 164 | * *) 165 | let enter_signature signature = 166 | let rec select_sig_item acc = function 167 | | [] -> List.rev acc 168 | (* variant, record, type_extension open, poly variant*) 169 | | ({sig_desc = Tsig_type (_,type_decl_list);_} as sig_item)::xs -> 170 | select_sig_item (make_pp_sig_type_set type_decl_list (sig_item :: acc)) xs 171 | (* type_extension extend *) 172 | | ({sig_desc = Tsig_typext (type_ext);_} as sig_item)::xs -> 173 | select_sig_item (make_pp_sig_type_ext type_ext (sig_item :: acc)) xs 174 | (* class *) 175 | | ({sig_desc = Tsig_class cdesclist;_} as sig_item)::xs -> 176 | select_sig_item (make_pp_sig_class_set cdesclist (sig_item :: acc)) xs 177 | | x::xs -> select_sig_item ((enter_signature_item x)::acc) xs 178 | in 179 | { signature with sig_items = (select_sig_item [] signature.sig_items) } 180 | 181 | (* 182 | * module Print open 183 | * *) 184 | let leave_structure structure = 185 | let str = { str_desc = 186 | Tstr_open { open_path = path_ident_create "Print"; 187 | open_txt = {txt=Lident "Print";loc=Location.none}; 188 | open_override = Fresh; 189 | open_loc = Location.none; 190 | open_attributes = []}; 191 | str_loc = Location.none; 192 | str_env = Env.empty} 193 | in 194 | { structure with str_items = str :: structure.str_items } 195 | 196 | (* 197 | * module_expr 198 | *) 199 | let rec enter_module_expr module_expr = 200 | match module_expr.mod_desc with 201 | | Tmod_functor (id,a,b,me) -> 202 | let name = Ident.name id in 203 | (ppopen := SSet.add name !ppopen; 204 | (let ret = enter_module_expr me in 205 | (*ppopen := SSet.remove name !ppopen;*) 206 | {module_expr with mod_desc = Tmod_functor (id,a,b,ret)})) 207 | | Tmod_apply (m1,m2,mc) -> 208 | {module_expr with mod_desc = Tmod_apply (enter_module_expr m1,enter_module_expr m2,mc)} 209 | | _ -> leave_module_expr module_expr 210 | end 211 | 212 | module Map = TypedtreeMap.MakeMap(MapArg) 213 | -------------------------------------------------------------------------------- /ocaml_at_p.ml: -------------------------------------------------------------------------------- 1 | module Main = Typpx.Make.F(struct 2 | let tool_name = "ocaml_at_p" 3 | let args = [] 4 | let firstUntypedTransformation = Typpx.Default.untyped_identity 5 | module Typemod = Typpx.Default.Typemod 6 | module TypedTransformation = Mod.Map 7 | let lastUntypedTransformation = Typpx.Default.untyped_identity 8 | end) 9 | 10 | let () = Main.run () 11 | 12 | -------------------------------------------------------------------------------- /opam/v1.0.1/opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | version: "1.0.1" 3 | authors: "Kenji Sakurai" 4 | maintainer: "kenji.sakurai.94@gmail.com" 5 | homepage: "https://github.com/tsubame-sp/ocaml_at_p" 6 | bug-reports: "https://github.com/tsubame-sp/ocaml_at_p/issues" 7 | dev-repo: "https://github.com/tsubame-sp/ocaml_at_p.git" 8 | build: [ 9 | [make "build" ] 10 | ] 11 | install: [ 12 | [make "install" ] 13 | ] 14 | remove: [ 15 | [make "remove" ] 16 | ] 17 | depends: [ 18 | "ocamlfind" 19 | "typpx" { >= "1.1.3" } 20 | ] 21 | available: [ 22 | ocaml-version >= "4.03.0" & ocaml-version < "4.04.0" 23 | ] 24 | -------------------------------------------------------------------------------- /opam/v1.0/opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | version: "1.0" 3 | authors: "Kenji Sakurai" 4 | maintainer: "kenji.sakurai.94@gmail.com" 5 | homepage: "https://github.com/tsubame-sp/ocaml_at_p" 6 | bug-reports: "https://github.com/tsubame-sp/ocaml_at_p/issues" 7 | dev-repo: "https://github.com/tsubame-sp/ocaml_at_p.git" 8 | build: [ 9 | [make "build" ] 10 | ] 11 | install: [ 12 | [make "install" ] 13 | ] 14 | remove: [ 15 | [make "uninstall" ] 16 | ] 17 | depends: [ 18 | "ocamlfind" { build & install & remove } 19 | "typpx" { >= "1.1.3" } 20 | ] 21 | available: [ 22 | ocaml-version >= "4.03.0" & ocaml-version < "4.04.0" 23 | ] 24 | -------------------------------------------------------------------------------- /opam/v1.1.0/descr: -------------------------------------------------------------------------------- 1 | OCaml@p : A debugging print system for OCaml 2 | 3 | OCaml@p is a tool supporting debug in OCaml programming. When you compile a program by this tool, this system make definition of print function automatically, and insert function call to print expression attached marker [@p] automatically. 4 | -------------------------------------------------------------------------------- /opam/v1.1.0/opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | version: "1.1.0" 3 | authors: "Kenji Sakurai" 4 | maintainer: "kenji.sakurai.94@gmail.com" 5 | homepage: "https://github.com/tsubame-sp/ocaml_at_p" 6 | bug-reports: "https://github.com/tsubame-sp/ocaml_at_p/issues" 7 | dev-repo: "https://github.com/tsubame-sp/ocaml_at_p.git" 8 | build: [ 9 | [make "build" ] 10 | ] 11 | install: [ 12 | [make "install" ] 13 | ] 14 | remove: [ 15 | [make "remove" ] 16 | ] 17 | depends: [ 18 | "ocamlfind" 19 | "typpx" { >= "1.1.3" } 20 | ] 21 | available: [ 22 | ocaml-version >= "4.03.0" & ocaml-version < "4.04.0" 23 | ] 24 | -------------------------------------------------------------------------------- /opam/v1.1.0/url: -------------------------------------------------------------------------------- 1 | archive: "https://github.com/tsubame-sp/ocaml_at_p/archive/1.1.0.tar.gz" 2 | -------------------------------------------------------------------------------- /print.ml: -------------------------------------------------------------------------------- 1 | (* ====================================================================== 2 | * Copyright © 2013 Keisuke Nakano. All rights reserved. 3 | *) 4 | 5 | open Format 6 | 7 | let strbuf = Buffer.create 1024 8 | 9 | let s_of _pp_a a = 10 | let prf = formatter_of_buffer strbuf in 11 | _pp_a prf a; pp_print_flush prf (); 12 | let str = Buffer.contents strbuf in 13 | Buffer.clear strbuf; 14 | str 15 | 16 | let _pp_int = pp_print_int 17 | let _pp_float = pp_print_float 18 | let _pp_char = pp_print_char 19 | let _pp_bool = pp_print_bool 20 | let _pp_string = pp_print_string 21 | let _pp_format6 prf fmt = _pp_string prf (string_of_format fmt^" : < format6 >") 22 | let _pp_unit prf () = _pp_string prf "()" 23 | 24 | 25 | (* list *) 26 | let _pp_list_empty prf _ = _pp_string prf "[]" 27 | 28 | let _pp_list_with sep _pp_a prf = function 29 | | [] -> () 30 | | x::xs -> 31 | _pp_a prf x; 32 | List.iter (fprintf prf "%s@;%a" sep _pp_a) xs 33 | 34 | let _pp_list _pp_a prf xs = fprintf prf "@[<1>[%a]@]" (_pp_list_with ";" _pp_a) xs 35 | 36 | (* array *) 37 | let _pp_array_empty prf _ = _pp_string prf "[||]" 38 | 39 | let _pp_array _pp_a prf xs = 40 | fprintf prf "@[<2>[|"; 41 | let len = Array.length xs in 42 | if len > 0 then begin 43 | _pp_a prf xs.(0); 44 | for i=1 to len-1 do fprintf prf ";@;%a" _pp_a xs.(i) done end; 45 | fprintf prf "|]@]" 46 | 47 | (* pp_poly *) 48 | type pp_poly = { pp_poly : 'b. 'b pp_neg -> 'b } 49 | and 'b pp_neg = { pp_neg : 'a. (formatter -> 'a -> unit) -> 'a -> 'b } 50 | let pp_poly _pp_a x = { pp_poly = fun k -> k.pp_neg _pp_a x } 51 | let apply_pp_poly prf p = p.pp_poly { pp_neg = fun _pp_a -> _pp_a prf } 52 | 53 | (* prefix operator for pp_poly *) 54 | let (!%) _pp_a = pp_poly _pp_a 55 | 56 | let rec string_forall p str i j = 57 | j < i || p str.[i] && string_forall p str (i+1) j 58 | 59 | (* PP for Heterogeneous list *) 60 | let pp_poly_list prf = function 61 | | [] -> () 62 | | [p] -> 63 | let s = s_of apply_pp_poly p in 64 | if s = "" then () 65 | else 66 | let is_atom = match s.[0] with 67 | | '(' | '[' | '{' | '<' | '"' | '\'' -> true 68 | | _ -> string_forall ( function 69 | | '0'..'9' | 'A'..'Z' | '_' | 'a'..'z' -> true 70 | | _ -> false ) s 1 (String.length s - 1) in 71 | if is_atom then fprintf prf " %a" apply_pp_poly p 72 | else fprintf prf "(%a)" apply_pp_poly p 73 | | p::ps -> 74 | fprintf prf "@[<1>(%a" apply_pp_poly p; 75 | List.iter (fprintf prf ",@;%a" apply_pp_poly) ps; 76 | fprintf prf ")@]" 77 | 78 | (* tuple *) 79 | let _pp_tuple (make_pps : 'a -> pp_poly list) prf x = pp_poly_list prf (make_pps x) 80 | 81 | let _pp__tuple2 _pp_a _pp_b prf x = 82 | _pp_tuple (fun (a,b) -> [ !%_pp_a a; !%_pp_b b ]) prf x 83 | 84 | let _pp__tuple3 _pp_a _pp_b _pp_c prf x = 85 | _pp_tuple (fun (a,b,c) -> [ !%_pp_a a; !%_pp_b b; !%_pp_c c ]) prf x 86 | 87 | let _pp__tuple4 _pp_a _pp_b _pp_c _pp_d prf x = 88 | _pp_tuple (fun (a,b,c,d) -> [ !%_pp_a a; !%_pp_b b; !%_pp_c c; !%_pp_d d ]) prf x 89 | 90 | let _pp__tuple5 _pp_a _pp_b _pp_c _pp_d _pp_e prf x = 91 | _pp_tuple (fun (a,b,c,d,e) -> [ !%_pp_a a; !%_pp_b b; !%_pp_c c; !%_pp_d d; !%_pp_e e ]) prf x 92 | 93 | let _pp__tuple6 _pp_a _pp_b _pp_c _pp_d _pp_e _pp_f prf x = 94 | _pp_tuple (fun (a,b,c,d,e,f) -> [ !%_pp_a a; !%_pp_b b; !%_pp_c c; !%_pp_d d; !%_pp_e e; !%_pp_f f ]) prf x 95 | 96 | let _pp__tuple7 _pp_a _pp_b _pp_c _pp_d _pp_e _pp_f _pp_g prf x = 97 | _pp_tuple (fun (a,b,c,d,e,f,g) -> [ !%_pp_a a; !%_pp_b b; !%_pp_c c; !%_pp_d d; !%_pp_e e; !%_pp_f f; !%_pp_g g ]) prf x 98 | 99 | 100 | (* variant *) 101 | let _pp__variant (make_cps : 'a -> string * pp_poly list) prf x = 102 | let constr_name, ps = make_cps x in 103 | fprintf prf "%s%a" constr_name pp_poly_list ps 104 | 105 | (* 106 | type pp_poly_variant_cps = PPConstr of string * pp_poly list | PPKnown of pp_poly 107 | 108 | let pp_poly_variant (make_cps : 'a -> pp_poly_variant_cps) prf x = 109 | match make_cps x with 110 | | PPConstr (c,ps) -> _pp_variant (fun () -> (c,ps)) prf () 111 | | PPKnown p -> apply_pp_poly prf p 112 | *) 113 | 114 | (* PP for option *) 115 | let _pp_option _pp_a prf a = 116 | _pp__variant (function 117 | | None -> "None", [] 118 | | Some x -> "Some", [!%_pp_a x] 119 | ) prf a 120 | 121 | (* PP for records and objects *) 122 | let _pp_recobj encL encC encR (make__pp_fields : 'a -> (string * pp_poly) list) prf x = 123 | let apply__pp_field prf (f,p) = fprintf prf "@[<2>%s %s @,%a@]" f encC apply_pp_poly p in 124 | fprintf prf "@[<1>%s" encL; 125 | begin match make__pp_fields x with 126 | | [] -> () 127 | | fp::fps -> 128 | apply__pp_field prf fp; 129 | List.iter (fprintf prf ";@;%a" apply__pp_field) fps end; 130 | fprintf prf "%s@]" encR 131 | 132 | let _pp__record mpf prf x = _pp_recobj "{" "=" "}" mpf prf x 133 | let _pp__object mpf prf x = _pp_recobj "<" ":" ">" mpf prf x 134 | 135 | (* Pervasive *) 136 | let _pp_fpclass prf x = _pp__variant (function 137 | | FP_normal -> "FP_normal", [] 138 | | FP_subnormal -> "FP_subnormal", [] 139 | | FP_zero -> "FP_zero", [] 140 | | FP_infinite -> "FP_infinite", [] 141 | | FP_nan -> "FP_nan", []) prf x 142 | 143 | let _pp_in_channel prf (_:in_channel) = _pp_string prf "< in_channel >" 144 | let _pp_out_channel prf (_:out_channel) = _pp_string prf "< out_channel >" 145 | 146 | let _pp_open_flag prf x = _pp__variant (function 147 | | Open_rdonly -> "Open_rdonly", [] 148 | | Open_wronly -> "Open_wronly", [] 149 | | Open_append -> "Open_append", [] 150 | | Open_creat -> "Open_creat", [] 151 | | Open_trunc -> "Open_trunc", [] 152 | | Open_excl -> "Open_excl", [] 153 | | Open_binary -> "Open_binary", [] 154 | | Open_text -> "Open_text", [] 155 | | Open_nonblock -> "Open_nonblock", []) prf x 156 | 157 | let _pp_ref _pp_a prf x = _pp__record (fun r -> ["contents", !%_pp_a r.contents]) prf x 158 | 159 | let _pp_format4 prf (fmt:(_,_,_,_) format4) = _pp_string prf (string_of_format fmt^" : < format4 >") 160 | let _pp_format prf (fmt:(_,_,_) format) = _pp_string prf (string_of_format fmt^" : < format >") 161 | 162 | let _pp_exn prf exn = _pp_string prf (Printexc.to_string exn) 163 | 164 | module String = struct 165 | include String 166 | let _pp_t prf x = _pp_string prf x 167 | end 168 | 169 | (* ===================================================================== *) 170 | 171 | let _pp_bytes prf x = _pp_string prf (Bytes.to_string x) 172 | 173 | let _pp__function str prf _ = _pp_string prf ("< fun : "^str^" >") 174 | 175 | let _pp_newline = pp_print_newline 176 | 177 | let _pp_int32 prf x = _pp_string prf (Int32.to_string x ^ "l") 178 | let _pp_int64 prf x = _pp_string prf (Int64.to_string x ^ "L") 179 | let _pp_nativeint prf x = _pp_string prf (Nativeint.to_string x ^ "n") 180 | let _pp_lazy_t _pp_a prf x = _pp_string prf "lazy ";_pp_a prf (Lazy.force x) 181 | 182 | let _pp__dump str prf _ = _pp_string prf str 183 | let _pp__unsup prf _ = _pp_string prf "< Unsupported Type >" 184 | let _pp__nouse prf _ = _pp_string prf "< This is dummy pp >" 185 | 186 | let _pp__trash prf x = () 187 | 188 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | FIND = ocamlfind 2 | OC = ocamlc 3 | OPT = ocamlopt 4 | FLAG = -package ocaml_at_p -linkpkg -w -A 5 | 6 | all: mylist.cmo test.cmo 7 | $(FIND) $(OC) $(FLAG) -o test mylist.cmo test.cmo 8 | 9 | opt: mylist.cmx test.cmx 10 | $(FIND) $(OPT) $(FLAG) -o test.opt mylist.cmx test.cmx 11 | 12 | src: mylist.cmo 13 | $(FIND) $(OC) $(FLAG) -dsource -c test.ml 14 | $(FIND) $(OC) $(FLAG) -o test mylist.cmo test.cmo 15 | 16 | mylist.cmo: mylist.ml 17 | $(FIND) $(OC) $(FLAG) -c mylist.ml 18 | 19 | test.cmo: test.ml 20 | $(FIND) $(OC) $(FLAG) -c test.ml 21 | 22 | mylist.cmx: mylist.ml 23 | $(FIND) $(OPT) $(FLAG) -c mylist.ml 24 | 25 | test.cmx: test.ml 26 | $(FIND) $(OPT) $(FLAG) -c test.ml 27 | 28 | clean: 29 | -rm test test.opt *.cm* *.o 30 | -------------------------------------------------------------------------------- /test/mylist.ml: -------------------------------------------------------------------------------- 1 | module M = struct 2 | type 'a mylist = MNil | MCons of ('a * 'a mylist) 3 | 4 | let rec length = function 5 | | MNil -> 0 6 | | MCons (_,xs) -> 1 + length xs 7 | 8 | type record = {a:int;b:float} 9 | end 10 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | [@@@ppopen Mylist] 2 | 3 | open Mylist.M 4 | 5 | module M2 : sig 6 | type t = int * string 7 | val first : t -> int 8 | end = struct 9 | type t = int * string 10 | let first (a : t) = fst a 11 | end 12 | 13 | module Incl = struct 14 | include Mylist.M 15 | end 16 | 17 | type m = int 18 | 19 | type m' = m 20 | 21 | type 'a v = A of 'a 22 | 23 | type 'a vv = 'a v = A of 'a 24 | 25 | type ('a,'b) v2 = A of 'a | B of 'b | C of 'a 26 | 27 | and ('a,'b) v3 = Tup of ('a * 'b) 28 | | Lis of ('a * 'b) list 29 | | Fun of ('a -> 'b) 30 | 31 | type r = {a:int list;b:float*string} 32 | 33 | type ('a,'b) r2 = {a2:'a;b2:'b} 34 | 35 | type odd = So of even 36 | 37 | and even = Se of odd | O 38 | 39 | type ex = .. 40 | 41 | type ex += Aex of int 42 | 43 | let _ = Aex 10 [@p] 44 | 45 | type ex += Bex of ex 46 | 47 | let _ = Bex (Aex 10) [@p] 48 | 49 | type p = [`A of p | `N] 50 | 51 | type p2 = [p | `B of p2] 52 | 53 | type podd = [`So of peven] 54 | 55 | and peven = [`Se of podd | `O] 56 | 57 | class c = object 58 | val mutable list = ( [] : int list ) 59 | method get = list 60 | method add a = list <- (a :: list) 61 | end 62 | 63 | and ['a] c2 = object(self) 64 | val mutable list = ( [] : 'a list ) 65 | method get = list 66 | method add a = list <- (a :: list) 67 | end 68 | 69 | let () = Format.(pp_print_newline std_formatter ()) 70 | 71 | let _ = 1 [@p] 72 | let _ = 1 [@p _this + 10] 73 | let _ = 3.14 [@p] 74 | let _ = 'A' [@p] 75 | let _ = true [@p] 76 | let _ = "abcde" [@p] 77 | let _ = ("%d" : _ format6) [@p] 78 | 79 | let _ = () [@p] 80 | let _ = Bytes.make 10 'B' [@p] 81 | 82 | let _ = stdin [@p] 83 | let _ = stdout [@p] 84 | let _ = stderr [@p] 85 | let _ = ("%d" : _ format4) [@p] 86 | let _ = ("%d" : _ format) [@p] 87 | 88 | let () = Format.(pp_print_newline std_formatter ()) 89 | 90 | let _ = [] [@p] 91 | let _ = [1;2;3] [@p] 92 | let _ = [[];[1];[2;3]] [@p] 93 | 94 | let _ = [||] [@p] 95 | let _ = [|1;2;3|] [@p] 96 | let _ = [|[||];[|1|];[|2;3|]|] [@p] 97 | 98 | let _ = (1,"abc") [@p] 99 | let _ = (1,3.14,'A',true,"abc","%d",()) [@p] 100 | let _ = (1,3.14,'A',true,"abc","%d",(),()) [@p] 101 | let _ = [(1,'A');(2,'B');(3,'C')] [@p] 102 | let _ = [|(1,'A');(2,'B');(3,'C')|] [@p] 103 | 104 | let () = Format.(pp_print_newline std_formatter ()) 105 | 106 | let _ = None [@p] 107 | let _ = Some 1 [@p] 108 | 109 | let _ = ref [] [@p] 110 | let _ = FP_normal [@p] 111 | let _ = Open_rdonly [@p] 112 | exception Exn 113 | let _ = Exn [@p] 114 | 115 | let () = Format.(pp_print_newline std_formatter ()) 116 | 117 | let _ = (fun x -> x+1) [@p] 118 | let _ = (fun ?(x=1) ~second:y -> x * y) [@p] 119 | 120 | let f a b = a + b 121 | let _ = f [@p] 122 | 123 | let _ = 10l [@p] 124 | let _ = 10L [@p] 125 | let _ = 10n [@p] 126 | let _ = lazy 10 [@p] 127 | 128 | let () = Format.(pp_print_newline std_formatter ()) 129 | 130 | let _ = [MNil;MNil] [@p] 131 | let _ = MNil [@p] 132 | let _ = MCons (10,MNil) [@p] 133 | let _ = length (MCons ('A',MNil)) [@p] 134 | let _ = ((10,"abc") : M2.t) [@p] 135 | let _ = M2.first ((1,"abc") : M2.t) [@p] 136 | 137 | let () = Format.(pp_print_newline std_formatter ()) 138 | 139 | let _ = (10 : m') [@p] 140 | let _ = A 100 [@p] 141 | let _ = (A 100 : _ vv) [@p] 142 | let _ = B ('B',"abc") [@p] 143 | let _ = Tup (1,1.) [@p] 144 | let _ = Lis [('A',"A")] [@p] 145 | let _ = Fun (fun x -> x) [@p] 146 | 147 | let () = Format.(pp_print_newline std_formatter ()) 148 | 149 | let _ = {a=[100];b=3.14,"3.14"} [@p] 150 | let _ = {a2=[100];b2=3.14,"3.14"} [@p] 151 | let _ = {a2=([1],['A']);b2=(['B'],[2])} [@p] 152 | let _ = {Mylist.M.a = 1;Mylist.M.b = 3.14} [@p] 153 | let _ = So (Se (So O)) [@p] 154 | 155 | let () = Format.(pp_print_newline std_formatter ()) 156 | 157 | let _ = `A `N [@p] 158 | let _ = (`A `N : p) [@p] 159 | let _ = (`B `N : p2) [@p] 160 | let _ = (`So (`Se (`So `O)) : podd) [@p] 161 | 162 | let () = Format.(pp_print_newline std_formatter ()) 163 | 164 | let _ = new c [@p] 165 | let cn = new c2 166 | let _ = cn [@p] 167 | let _ = let _ = cn#add 1 in cn [@p] 168 | 169 | let _ = {Incl.a = 1;Incl.b = 3.14} [@p] 170 | 171 | let () = Format.(pp_print_newline std_formatter ()) 172 | 173 | let x [@p] = 10 174 | let Some e [@p] = Some "String" 175 | 176 | let () = Format.(pp_print_newline std_formatter ()) 177 | 178 | let _ = 179 | let x [@p] = 10 in 180 | let (a,b) [@p] = (1,'A') in 181 | let [l1;l2;l3] [@p] = [1;2;3] in 182 | let y::ys [@p] = [1;2;3] in 183 | let {a=a_elm;b=b_elm} [@p] = {a=[10];b=(2e5,"2e^5")} in 184 | let Some e [@p] = Some 10 in 185 | let `Some e2 [@p] = `Some 20 in 186 | let ((fst,10)|(fst,20)) [@p] = (10,10) in 187 | Format.(pp_print_string std_formatter "DONE.\n"); 188 | ignore(x,a,b,l1,l2,l3,y,ys,a_elm,b_elm,e,e2,fst) 189 | --------------------------------------------------------------------------------