├── .gitignore ├── .merlin ├── .ocp-indent ├── .travis.yml ├── Dockerfile ├── LICENSE ├── META ├── _tags ├── develop ├── doc ├── api.odocl └── style.css ├── examples ├── configs │ ├── .merlin │ ├── _tags │ ├── makefile │ ├── myocamlbuild.ml │ └── src │ │ ├── config.ml │ │ └── main.ml ├── debug.ml │ ├── .merlin │ ├── _tags │ ├── makefile │ ├── myocamlbuild.ml │ └── src │ │ ├── VarGen.ml │ │ ├── config.ml │ │ ├── debug.ml │ │ ├── main.ml │ │ ├── other.ml │ │ └── xdebug.cppo └── minimal │ ├── .merlin │ ├── _tags │ ├── main.ml │ ├── makefile │ └── myocamlbuild.ml ├── makefile ├── myocamlbuild.ml ├── opam ├── readme.md ├── report.pdf ├── slides.pdf ├── src ├── PPCoerce.ml ├── PPConfig.ml ├── PPDriver.ml ├── PPEnv.ml ├── PPShow.ml ├── PPTrace.ml ├── PPUtil.ml ├── PolyPrint.ml ├── PolyPrint.mllib ├── _tags ├── ppx_polyprint.ml └── typing │ ├── PPTypeclass.ml │ ├── PPTypeclass.mli │ ├── PPTypecore.ml │ ├── PPTypecore.mli │ ├── PPTypemod.ml │ └── PPTypemod.mli └── test ├── _tags ├── noppx.ml ├── ppx.ml ├── test.ml └── test_util.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | _tests/ 3 | *.native 4 | *.byte 5 | *.out 6 | *.docdir 7 | *.log 8 | 9 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | B _build/src 2 | B _build/test 3 | PKG alcotest compiler-libs.common typpx ppx_tools.metaquot str 4 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | match_clause=4 2 | strict_with=auto -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh 3 | script: bash -ex .travis-opam.sh 4 | sudo: true 5 | env: 6 | - PACKAGE=ppx_polyprint OCAML_VERSION=4.02 7 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:ubuntu-16.04_ocaml-4.02.3 2 | 3 | RUN opam update && opam install ocamlfind 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 Darius Foo 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /META: -------------------------------------------------------------------------------- 1 | version = "0.0.0" 2 | description = "A polymorphic print function" 3 | archive(byte) = "PolyPrint.cma" 4 | archive(native) = "PolyPrint.cmxa" 5 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: bin_annot, safe_string 2 | "src": include 3 | "src/typing": include 4 | "test": include 5 | -------------------------------------------------------------------------------- /develop: -------------------------------------------------------------------------------- 1 | docker build -t polyprint_dev . 2 | docker run -it -v "$(pwd)":/ppx_polyprint -w /ppx_polyprint "$(docker images -q polyprint_dev)" bash -c 'make up; exec bash' 3 | -------------------------------------------------------------------------------- /doc/api.odocl: -------------------------------------------------------------------------------- 1 | src/PolyPrint -------------------------------------------------------------------------------- /doc/style.css: -------------------------------------------------------------------------------- 1 | /* A style for ocamldoc. Daniel C. Buenzli */ 2 | 3 | /* Reset a few things. */ 4 | html,body,div,span,applet,object,iframe,h1,h2,h3,h4,h5,h6,p,blockquote,pre, 5 | a,abbr,acronym,address,big,cite,code,del,dfn,em,font,img,ins,kbd,q,s,samp, 6 | small,strike,strong,sub,sup,tt,var,b,u,i,center,dl,dt,dd,ol,ul,li,fieldset, 7 | form,label,legend,table,caption,tbody,tfoot,thead,tr,th,td 8 | { margin: 0; padding: 0; border: 0 none; outline: 0; font-size: 100%; 9 | font-weight: inherit; font-style:inherit; font-family:inherit; 10 | line-height: inherit; vertical-align: baseline; text-align:inherit; 11 | color:inherit; background: transparent; } 12 | 13 | table { border-collapse: collapse; border-spacing: 0; } 14 | 15 | /* Basic page layout */ 16 | 17 | body { font: normal 10pt/1.375em helvetica, arial, sans-serif; text-align:left; 18 | margin: 1.375em 10%; min-width: 40ex; max-width: 72ex; 19 | color: black; background: transparent /* url(line-height-22.gif) */; } 20 | 21 | b { font-weight: bold } 22 | em { font-style: italic } 23 | 24 | tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace; 25 | font-size: 1em; } 26 | pre code { font-size : inherit; } 27 | .codepre { margin-bottom:1.375em /* after code example we introduce space. */ } 28 | 29 | .superscript,.subscript 30 | { font-size : 0.813em; line-height:0; margin-left:0.4ex;} 31 | .superscript { vertical-align: super; } 32 | .subscript { vertical-align: sub; } 33 | 34 | /* ocamldoc markup workaround hacks */ 35 | 36 | 37 | 38 | hr, hr + br, div + br, center + br, span + br, ul + br, ol + br, pre + br 39 | { display: none } /* annoying */ 40 | 41 | div.info + br { display:block} 42 | 43 | .codepre br + br { display: none } 44 | h1 + pre { margin-bottom:1.375em} /* Toplevel module description */ 45 | 46 | /* Sections and document divisions */ 47 | 48 | /* .navbar { margin-bottom: -1.375em } */ 49 | h1 { font-weight: bold; font-size: 1.5em; /* margin-top:1.833em; */ 50 | margin-top:0.917em; padding-top:0.875em; 51 | border-top-style:solid; border-width:1px; border-color:#AAA; } 52 | h2 { font-weight: bold; font-size: 1.313em; margin-top: 1.048em } 53 | h3 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } 54 | h3 { font-weight: bold; font-size: 1em; margin-top: 1.375em} 55 | h4 { font-style: italic; } 56 | 57 | /* Used by OCaml's own library documentation. */ 58 | h6 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } 59 | .h7 { font-weight: bold; font-size: 1em; margin-top: 1.375em } 60 | 61 | p { margin-top: 1.375em } 62 | pre { margin-top: 1.375em } 63 | .info { margin: 0.458em 0em -0.458em 2em;}/* Description of types values etc. */ 64 | td .info { margin:0; padding:0; margin-left: 2em;} /* Description in indexes */ 65 | 66 | ul, ol { margin-top:0.688em; padding-bottom:0.687em; 67 | list-style-position:outside} 68 | ul + p, ol + p { margin-top: 0em } 69 | ul { list-style-type: square } 70 | 71 | 72 | /* h2 + ul, h3 + ul, p + ul { } */ 73 | ul > li { margin-left: 1.375em; } 74 | ol > li { margin-left: 1.7em; } 75 | /* Links */ 76 | 77 | a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none } 78 | a:hover { text-decoration : underline } 79 | *:target {background-color: #FFFF99;} /* anchor highlight */ 80 | 81 | /* Code */ 82 | 83 | .keyword { font-weight: bold; } 84 | .comment { color : red } 85 | .constructor { color : green } 86 | .string { color : brown } 87 | .warning { color : red ; font-weight : bold } 88 | 89 | /* Functors */ 90 | 91 | .paramstable { border-style : hidden ; padding-bottom:1.375em} 92 | .paramstable code { margin-left: 1ex; margin-right: 1ex } 93 | .sig_block {margin-left: 1em} 94 | 95 | /* Images */ 96 | 97 | img { margin-top: 1.375em } 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | -------------------------------------------------------------------------------- /examples/configs/.merlin: -------------------------------------------------------------------------------- 1 | B _build/** 2 | S src 3 | PKG ppx_polyprint 4 | -------------------------------------------------------------------------------- /examples/configs/_tags: -------------------------------------------------------------------------------- 1 | true: package(str), annot, package(ppx_polyprint) 2 | : polyprint_native 3 | -------------------------------------------------------------------------------- /examples/configs/makefile: -------------------------------------------------------------------------------- 1 | 2 | OCB_FLAGS = -use-ocamlfind -I src 3 | 4 | OCB = ocamlbuild $(OCB_FLAGS) 5 | 6 | all: clean 7 | $(OCB) main.byte 8 | ./main.byte -dre .* 9 | 10 | clean: 11 | $(OCB) -clean 12 | rm -f *.byte 13 | -------------------------------------------------------------------------------- /examples/configs/myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | 2 | open Ocamlbuild_plugin 3 | 4 | let () = 5 | dispatch ( 6 | function 7 | | After_rules -> 8 | flag ["ocaml"; "compile"; "polyprint_native"] & 9 | S [A "-ppx"; A "$(ocamlfind query ppx_polyprint)/ppx_polyprint"] 10 | | _ -> ()) 11 | -------------------------------------------------------------------------------- /examples/configs/src/config.ml: -------------------------------------------------------------------------------- 1 | 2 | module Recursive : PolyPrint.TraceConfig = struct 3 | 4 | let depth = ref 0 5 | 6 | let spaces n = 7 | let rec aux bar n = 8 | match n with 9 | | 0 -> "" 10 | | n -> (if bar then "| " else " ") ^ aux (not bar) (n - 1) 11 | in aux true n 12 | 13 | let incr_depth () = 14 | spaces !depth |> print_string; 15 | incr depth 16 | 17 | let decr_depth () = 18 | decr depth; 19 | spaces !depth |> print_string 20 | 21 | class api = object (self) 22 | inherit PolyPrint.DefaultTraceConfig.api as super 23 | 24 | method print_result fn_name pr_res res = 25 | decr_depth (); 26 | super#print_result fn_name pr_res res 27 | 28 | method run1 fn_name a pr_res fn = 29 | incr_depth (); 30 | super#run1 fn_name a pr_res fn 31 | 32 | method run2 fn_name a b pr_res fn = 33 | incr_depth (); 34 | super#run2 fn_name a b pr_res fn 35 | 36 | method run3 fn_name a b c pr_res fn = 37 | incr_depth (); 38 | super#run3 fn_name a b c pr_res fn 39 | 40 | method run4 fn_name a b c d pr_res fn = 41 | incr_depth (); 42 | super#run4 fn_name a b c d pr_res fn 43 | 44 | method run5 fn_name a b c d e pr_res fn = 45 | incr_depth (); 46 | super#run5 fn_name a b c d e pr_res fn 47 | 48 | method run6 fn_name a b c d e f pr_res fn = 49 | incr_depth (); 50 | super#run6 fn_name a b c d e f pr_res fn 51 | 52 | method run7 fn_name a b c d e f g pr_res fn = 53 | incr_depth (); 54 | super#run7 fn_name a b c d e f g pr_res fn 55 | end 56 | 57 | let act = new api 58 | end 59 | 60 | module Minimal : PolyPrint.TraceConfig = struct 61 | class api = object (self) 62 | inherit Recursive.api 63 | 64 | method fn name = name ^ "" 65 | method arg _ value = value 66 | method result _ value = "= " ^ value 67 | end 68 | 69 | let act = new api 70 | end 71 | -------------------------------------------------------------------------------- /examples/configs/src/main.ml: -------------------------------------------------------------------------------- 1 | 2 | open Config 3 | 4 | let rec fact n = 5 | if n = 0 then 1 else n * fact (n - 1) 6 | [@@tracerec Recursive] 7 | 8 | let rec roll n = 9 | match n with 10 | | 0 -> () 11 | | 3 -> ignore @@ fact 5; roll 2 12 | | n -> roll (n - 1) 13 | [@@tracerec Recursive] 14 | 15 | let rec fib n = 16 | if n <= 1 then 1 else fib (n - 1) + fib (n - 2) 17 | [@@tracerec Minimal] 18 | 19 | let () = 20 | roll 5; 21 | ignore @@ fib 5 22 | -------------------------------------------------------------------------------- /examples/debug.ml/.merlin: -------------------------------------------------------------------------------- 1 | B _build/** 2 | S src 3 | PKG ppx_polyprint 4 | -------------------------------------------------------------------------------- /examples/debug.ml/_tags: -------------------------------------------------------------------------------- 1 | true: package(str), annot, package(ppx_polyprint), pp(cppo -D TRACE) 2 | : polyprint_native 3 | -------------------------------------------------------------------------------- /examples/debug.ml/makefile: -------------------------------------------------------------------------------- 1 | 2 | OCB_FLAGS = -use-ocamlfind -I src 3 | 4 | OCB = ocamlbuild $(OCB_FLAGS) 5 | 6 | all: clean 7 | $(OCB) main.byte 8 | ./main.byte -dre .* 9 | 10 | clean: 11 | $(OCB) -clean 12 | rm -f *.byte 13 | -------------------------------------------------------------------------------- /examples/debug.ml/myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | 2 | open Ocamlbuild_plugin 3 | 4 | let () = 5 | dispatch ( 6 | function 7 | | After_rules -> 8 | flag ["ocaml"; "compile"; "polyprint_native"] & 9 | S [A "-ppx"; A "$(ocamlfind query ppx_polyprint)/ppx_polyprint"] 10 | | _ -> ()) 11 | -------------------------------------------------------------------------------- /examples/debug.ml/src/VarGen.ml: -------------------------------------------------------------------------------- 1 | let dummy = () 2 | 3 | 4 | type print_level = 5 | (* | P_Quiet *) 6 | (* | P_VShort *) 7 | | P_Short 8 | | P_Norm (* default *) 9 | | P_Detail 10 | (* | P_Debug *) 11 | 12 | type print_set = 13 | | PS_Debug (* to assist with debugging *) 14 | | PS_Type (* to print type *) 15 | | PS_Quiet (* quiet printing *) 16 | | PS_Orig_Conseq (* quiet printing *) 17 | | PS_Tidy (* quiet printing *) 18 | | PS_IParams (* quiet printing *) 19 | | PS_HTML (* quiet printing *) 20 | 21 | let compete_mode = ref false 22 | let trace_failure = ref false 23 | let trace_exc = ref false 24 | let trace_loop = ref false 25 | let trace_loop_all = ref false 26 | let verbose_num = ref 0 27 | 28 | let last_posn = ref (None:string option) 29 | 30 | let suppress_warning_msg = ref false 31 | let en_warning_msg = ref true 32 | 33 | let sap = ref false 34 | 35 | type loc = { 36 | start_pos : Lexing.position (* might be expanded to contain more information *); 37 | mid_pos : Lexing.position; 38 | end_pos : Lexing.position; 39 | } 40 | 41 | type primed = 42 | | Primed 43 | | Unprimed 44 | 45 | let string_of_primed p = 46 | match p with 47 | | Primed -> "Primed" 48 | | Unprimed -> "Unprimed" 49 | 50 | let no_pos = 51 | let no_pos1 = { Lexing.pos_fname = ""; 52 | Lexing.pos_lnum = 0; 53 | Lexing.pos_bol = 0; 54 | Lexing.pos_cnum = 0 } in 55 | {start_pos = no_pos1; mid_pos = no_pos1; end_pos = no_pos1;} 56 | 57 | 58 | let is_no_pos l = (l.start_pos.Lexing.pos_cnum == 0) 59 | 60 | let print_endline_q s = 61 | if !compete_mode then () 62 | else print_endline s 63 | 64 | let print_backtrace_quiet () = 65 | if !compete_mode then () 66 | else 67 | Printexc.print_backtrace stdout 68 | 69 | let get_backtrace_quiet () = 70 | if !compete_mode then "" 71 | else 72 | Printexc.get_backtrace () 73 | 74 | let record_backtrace_quite () = 75 | if !compete_mode then () 76 | else 77 | Printexc.record_backtrace !trace_failure 78 | 79 | let string_of_loc (p : loc) = 80 | p.start_pos.Lexing.pos_fname ^ "_" ^ 81 | (string_of_int p.start_pos.Lexing.pos_lnum) ^ ":" ^ 82 | (string_of_int (p.start_pos.Lexing.pos_cnum-p.start_pos.Lexing.pos_bol)) ^ "_" ^ 83 | (string_of_int p.end_pos.Lexing.pos_lnum) ^ ":" ^ 84 | (string_of_int (p.end_pos.Lexing.pos_cnum-p.end_pos.Lexing.pos_bol)) 85 | 86 | let string_of_pos (p : Lexing.position) = "("^string_of_int(p.Lexing.pos_lnum) ^","^string_of_int(p.Lexing.pos_cnum-p.Lexing.pos_bol) ^")" 87 | ;; 88 | 89 | let string_of_full_loc (l : loc) = "{"^(string_of_pos l.start_pos)^","^(string_of_pos l.end_pos)^"}";; 90 | 91 | let string_of_loc_by_char_num (l : loc) = 92 | Printf.sprintf "(%d-%d)" 93 | l.start_pos.Lexing.pos_cnum 94 | l.end_pos.Lexing.pos_cnum 95 | 96 | let eq_pos p1 p2 = 97 | (p1.Lexing.pos_lnum == p2.Lexing.pos_lnum) && 98 | (p1.Lexing.pos_cnum - p1.Lexing.pos_bol) == (p2.Lexing.pos_cnum - p2.Lexing.pos_bol) 99 | 100 | let eq_loc l1 l2 = 101 | eq_pos l1.start_pos l2.start_pos 102 | 103 | (*Proof logging facilities*) 104 | class ['a] store (x_init:'a) (epr:'a->string) = 105 | object (self) 106 | val emp_val = x_init 107 | val mutable lc = None 108 | method is_avail : bool = match lc with 109 | | None -> false 110 | | Some _ -> true 111 | method is_empty : bool = lc == None 112 | method set (nl:'a) = lc <- Some nl 113 | method get :'a = match lc with 114 | | None -> emp_val 115 | | Some p -> p 116 | method reset = lc <- None 117 | method get_rm :'a = match lc with 118 | | None -> emp_val 119 | | Some p -> (lc <- None; p) 120 | method replace (nl:'a) = 121 | if not (self # is_empty) then self # set nl 122 | else () 123 | method string_of : string = match lc with 124 | | None -> "Why None?" 125 | | Some l -> (epr l) 126 | method dump = print_endline ("\n store dump :"^(self#string_of)) 127 | end;; 128 | 129 | class ['a] store_debug (x_init:'a) (epr:'a->string) = 130 | object (self) 131 | inherit ['a] store x_init epr as super 132 | method reset = 133 | if super # is_avail then 134 | begin 135 | print_endline ("reset:"^self#get); 136 | super # reset 137 | end 138 | method get_rm :'a = 139 | print_endline ("get_rm:"^self#get); 140 | super # get_rm 141 | end;; 142 | 143 | (* this will be set to true when we are in error explanation module *) 144 | class failure_mode = 145 | object 146 | inherit [bool] store false string_of_bool 147 | end;; 148 | 149 | class prog_loc = 150 | object 151 | inherit [loc] store no_pos string_of_loc 152 | method string_of_pos : string = match lc with 153 | | None -> "None" 154 | | Some l -> (string_of_pos l.start_pos) 155 | end;; 156 | 157 | let method_name_of s = 158 | try 159 | let hashtag_index = String.index s '#' in 160 | String.sub s 0 hashtag_index 161 | with _ -> s 162 | 163 | let is_equal call_name s = 164 | String.compare call_name (method_name_of s) = 0 165 | 166 | class last_posn_cls = 167 | object (self) 168 | val last_posn = new store ("", "") (fun (x, _) -> "("^x^")") 169 | method reset (s: string): unit = 170 | if last_posn # is_avail then 171 | let last_call_site, last_call_name = last_posn # get in 172 | (* let () = print_endline ("last_posn reset: " ^ s ^ " @" ^ last_call_site ^ ":" ^ last_call_name) in *) 173 | if is_equal last_call_name s then last_posn # reset 174 | else () 175 | else () 176 | method get_rm (s: string) = 177 | let last_call_site, last_call_name = last_posn # get in 178 | (* let () = print_endline ("last_posn get_rm: " ^ s ^ " @" ^ last_call_site ^ ":" ^ last_call_name) in *) 179 | if is_equal last_call_name s then 180 | let () = last_posn # reset in 181 | last_call_site 182 | else "" 183 | method get (s: string) = 184 | let last_call_site, last_call_name = last_posn # get in 185 | if is_equal last_call_name s then last_call_site 186 | else "" 187 | method set_name (s: string) = 188 | let last_call_site, last_call_name = last_posn # get in 189 | if last_call_name = "" then last_posn # replace (last_call_site, s) 190 | method set_posn pos = 191 | last_posn # set (pos, "") 192 | end;; 193 | 194 | let last_posn = new last_posn_cls 195 | (* let last_posn = new store(* _debug *) ("", "") (fun (x, _) -> "("^x^")") *) 196 | 197 | (*Some global vars for logging*) 198 | let proving_loc = new prog_loc 199 | let post_pos = new prog_loc 200 | 201 | let entail_pos = ref no_pos 202 | let set_entail_pos p = entail_pos := p 203 | 204 | (* what is this flag for? *) 205 | let z_debug_flag = ref false 206 | 207 | let buildA s i = s^"#"^(string_of_int i);; 208 | let build_loc_str s i = "**"^(buildA s i)^":";; 209 | let store_loc_str s i = 210 | if !z_debug_flag then 211 | let n = buildA s i 212 | in last_posn # set_posn n;; 213 | -------------------------------------------------------------------------------- /examples/debug.ml/src/config.ml: -------------------------------------------------------------------------------- 1 | 2 | module Adapter : PolyPrint.TraceConfig = struct 3 | 4 | class api = object (self) 5 | inherit PolyPrint.DefaultTraceConfig.api as super 6 | 7 | method run1 fn_name (a_n, pr_a, a) pr_res fn = 8 | Debug.no_1 fn_name pr_a pr_res fn a 9 | 10 | method run2 fn_name (a_n, pr_a, a) (b_n, pr_b, b) pr_res fn = 11 | Debug.no_2 fn_name pr_a pr_b pr_res fn a b 12 | 13 | method run3 fn_name (a_n, pr_a, a) (b_n, pr_b, b) (c_n, pr_c, c) pr_res fn = 14 | Debug.no_3 fn_name pr_a pr_b pr_c pr_res fn a b c 15 | 16 | method run4 fn_name (a_n, pr_a, a) (b_n, pr_b, b) (c_n, pr_c, c) (d_n, pr_d, d) pr_res fn = 17 | Debug.no_4 fn_name pr_a pr_b pr_c pr_d pr_res fn a b c d 18 | 19 | method run5 fn_name (a_n, pr_a, a) (b_n, pr_b, b) (c_n, pr_c, c) (d_n, pr_d, d) (e_n, pr_e, e) pr_res fn = 20 | Debug.no_5 fn_name pr_a pr_b pr_c pr_d pr_e pr_res fn a b c d e 21 | 22 | method run6 fn_name (a_n, pr_a, a) (b_n, pr_b, b) (c_n, pr_c, c) (d_n, pr_d, d) (e_n, pr_e, e) (f_n, pr_f, f) pr_res fn = 23 | Debug.no_6 fn_name pr_a pr_b pr_c pr_d pr_e pr_f pr_res fn a b c d e f 24 | 25 | method run7 fn_name (a_n, pr_a, a) (b_n, pr_b, b) (c_n, pr_c, c) (d_n, pr_d, d) (e_n, pr_e, e) (f_n, pr_f, f) (g_n, pr_g, g) pr_res fn = 26 | Debug.no_7 fn_name pr_a pr_b pr_c pr_d pr_e pr_f pr_g pr_res fn a b c d e f g 27 | 28 | method call1 (file, line) fn a = 29 | Debug.wrap_z_debug VarGen.store_loc_str file line; 30 | fn a 31 | 32 | method call2 (file, line) fn a b = 33 | Debug.wrap_z_debug VarGen.store_loc_str file line; 34 | fn a b 35 | 36 | method call3 (file, line) fn a b c = 37 | Debug.wrap_z_debug VarGen.store_loc_str file line; 38 | fn a b c 39 | 40 | method call4 (file, line) fn a b c d = 41 | Debug.wrap_z_debug VarGen.store_loc_str file line; 42 | fn a b c d 43 | 44 | method call5 (file, line) fn a b c d e = 45 | Debug.wrap_z_debug VarGen.store_loc_str file line; 46 | fn a b c d e 47 | 48 | method call6 (file, line) fn a b c d e f = 49 | Debug.wrap_z_debug VarGen.store_loc_str file line; 50 | fn a b c d e f 51 | 52 | method call7 (file, line) fn a b c d e f g = 53 | Debug.wrap_z_debug VarGen.store_loc_str file line; 54 | fn a b c d e f g 55 | end 56 | 57 | let act = new api 58 | end 59 | -------------------------------------------------------------------------------- /examples/debug.ml/src/main.ml: -------------------------------------------------------------------------------- 1 | 2 | open Config 3 | open Other 4 | 5 | [@@@polyprint Adapter] 6 | 7 | let plus a b = a + b 8 | [@@trace Adapter; a] 9 | 10 | let () = 11 | Arg.parse Debug.command_args (fun _ -> ()) ""; 12 | ignore @@ fact 5; 13 | ignore @@ plus 2 5; 14 | -------------------------------------------------------------------------------- /examples/debug.ml/src/other.ml: -------------------------------------------------------------------------------- 1 | 2 | open Config 3 | 4 | [@@@polyprint Adapter] 5 | 6 | let rec fact n = 7 | if n = 0 then 1 else n * fact (n - 1) 8 | [@@tracerec Adapter] 9 | -------------------------------------------------------------------------------- /examples/debug.ml/src/xdebug.cppo: -------------------------------------------------------------------------------- 1 | #define n_binfo_hp Debug.binfo_hprint 2 | #define n_binfo_pp Debug.binfo_pprint 3 | #define n_binfo_zp Debug.binfo_zprint 4 | #define x_loc (build_loc_str __FILE__ __LINE__) 5 | #define x_tbi ((build_loc_str __FILE__ __LINE__)^"TBI") 6 | #define fail_tbi (failwith ((build_loc_str __FILE__ __LINE__)^"TBI")) 7 | #ifdef TRACE 8 | #define x_info_hp (fun f -> \ 9 | Debug.binfo_hprint (fun x -> (VarGen.build_loc_str __FILE__ __LINE__)^(f x))) 10 | #define x_info_pp (fun s -> \ 11 | Debug.binfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^s)) 12 | #define x_info_zp (fun s -> \ 13 | Debug.binfo_zprint (lazy ((VarGen.build_loc_str __FILE__ __LINE__)^(Lazy.force s)))) 14 | #define x_binfo_hp (fun f -> \ 15 | Debug.binfo_hprint (fun x -> (VarGen.build_loc_str __FILE__ __LINE__)^(f x))) 16 | #define x_binfo_pp (fun s -> \ 17 | Debug.binfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^s)) 18 | #define x_binfo_zp (fun s -> \ 19 | Debug.binfo_zprint (lazy ((VarGen.build_loc_str __FILE__ __LINE__)^(Lazy.force s)))) 20 | #define x_tinfo_hp (fun f -> \ 21 | Debug.tinfo_hprint (fun x -> (VarGen.build_loc_str __FILE__ __LINE__)^(f x))) 22 | #define x_tinfo_pp (fun s -> \ 23 | Debug.tinfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^s)) 24 | #define x_tinfo_zp (fun s -> \ 25 | Debug.tinfo_zprint (lazy ((VarGen.build_loc_str __FILE__ __LINE__)^(Lazy.force s)))) 26 | #define x_dinfo_hp (fun f -> \ 27 | Debug.dinfo_hprint (fun x -> (VarGen.build_loc_str __FILE__ __LINE__)^(f x))) 28 | #define x_dinfo_pp (fun s -> \ 29 | Debug.dinfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^s)) 30 | #define x_dinfo_zp (fun s -> \ 31 | Debug.dinfo_zprint (lazy ((VarGen.build_loc_str __FILE__ __LINE__)^(Lazy.force s)))) 32 | #define x_winfo_pp (fun s -> \ 33 | Debug.winfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^s)) 34 | #define x_winfo_hp (fun f -> \ 35 | Debug.binfo_hprint (fun x -> (VarGen.build_loc_str __FILE__ __LINE__)^(f x))) 36 | #define x_winfo_zp (fun s -> \ 37 | Debug.binfo_zprint (lazy ((VarGen.build_loc_str __FILE__ __LINE__)^(Lazy.force s)))) 38 | #define x_report_error (fun lc s -> \ 39 | Gen.report_error lc ((VarGen.build_loc_str __FILE__ __LINE__)^s)) 40 | #define x_ninfo_hp (fun pr s p -> ()) 41 | #define x_ninfo_pp (fun s p -> ()) 42 | #define x_ninfo_zp (fun s p -> ()) 43 | #define y_info_hp (fun f -> \ 44 | Debug.y_binfo_hprint (fun x -> (VarGen.build_loc_str __FILE__ __LINE__)^(f x))) 45 | #define y_info_pp (fun s -> \ 46 | Debug.y_binfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^s)) 47 | #define y_binfo_hp (fun f -> \ 48 | Debug.y_binfo_hprint (fun x -> (VarGen.build_loc_str __FILE__ __LINE__)^(f x))) 49 | #define y_binfo_pp (fun s -> \ 50 | Debug.y_binfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^s)) 51 | #define y_binfo_zp (fun s -> \ 52 | Debug.y_binfo_zprint (lazy ((VarGen.build_loc_str __FILE__ __LINE__)^(Lazy.force s)))) 53 | #define y_tinfo_hp (fun f -> \ 54 | Debug.y_tinfo_hprint (fun x -> (VarGen.build_loc_str __FILE__ __LINE__)^(f x))) 55 | #define y_tinfo_pp (fun s -> \ 56 | Debug.y_tinfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^s)) 57 | #define y_tinfo_zp (fun s -> \ 58 | Debug.y_tinfo_zprint (lazy ((VarGen.build_loc_str __FILE__ __LINE__)^(Lazy.force s)))) 59 | #define y_dinfo_hp (fun f -> \ 60 | Debug.y_dinfo_hprint (fun x -> (VarGen.build_loc_str __FILE__ __LINE__)^(f x))) 61 | #define y_dinfo_pp (fun s -> \ 62 | Debug.y_dinfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^s)) 63 | #define y_dinfo_zp (fun s -> \ 64 | Debug.y_dinfo_zprint (lazy ((VarGen.build_loc_str __FILE__ __LINE__)^(Lazy.force s)))) 65 | #define y_winfo_pp (fun s -> \ 66 | Debug.y_winfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^s)) 67 | #define y_winfo_hp (fun f -> \ 68 | Debug.y_binfo_hprint (fun x -> (VarGen.build_loc_str __FILE__ __LINE__)^(f x))) 69 | #define y_winfo_zp (fun s -> \ 70 | Debug.y_binfo_zprint (lazy ((VarGen.build_loc_str __FILE__ __LINE__)^(Lazy.force s)))) 71 | #define y_ninfo_hp (fun pr s -> ()) 72 | #define y_ninfo_pp (fun s > ()) 73 | #define y_ninfo_zp (fun s -> ()) 74 | #define y_bres_hp (fun f r -> \ 75 | let () = Debug.y_binfo_hprint (fun x -> (VarGen.build_loc_str __FILE__ __LINE__)^(f x)) r in r) 76 | #define y_tres_hp (fun f r -> \ 77 | let () = Debug.y_tinfo_hprint (fun x -> (VarGen.build_loc_str __FILE__ __LINE__)^(f x)) r in r) 78 | #define x_add_0 (fun f -> let () = Debug.wrap_z_debug VarGen.store_loc_str __FILE__ __LINE__ in f) 79 | #define x_add_1 (fun f x -> let () = Debug.wrap_z_debug VarGen.store_loc_str __FILE__ __LINE__ in f x) 80 | #define x_add (fun f x y -> let () = Debug.wrap_z_debug VarGen.store_loc_str __FILE__ __LINE__ in f x y) 81 | #define x_add_3 (fun f a b c -> let () = Debug.wrap_z_debug VarGen.store_loc_str __FILE__ __LINE__ in f a b c) 82 | #define x_noop 83 | #define x_todo (fun s -> \ 84 | Debug.y_binfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^"TODO: "^s)) 85 | #define x_nodo (fun s -> \ 86 | Debug.y_tinfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^"TODO: "^s)) 87 | #define x_warn (fun s -> \ 88 | Debug.y_binfo_pprint ((VarGen.build_loc_str __FILE__ __LINE__)^"WARNING: "^s)) 89 | #define x_fail (fun s -> \ 90 | failwith ((VarGen.build_loc_str __FILE__ __LINE__)^s)) 91 | #else 92 | #define x_binfo_hp Debug.binfo_hprint 93 | #define x_binfo_pp Debug.binfo_pprint 94 | #define x_binfo_zp Debug.binfo_zprint 95 | #define x_tinfo_hp Debug.tinfo_hprint 96 | #define x_tinfo_pp Debug.tinfo_pprint 97 | #define x_tinfo_zp Debug.tinfo_zprint 98 | #define x_dinfo_hp Debug.dinfo_hprint 99 | #define x_dinfo_pp Debug.dinfo_pprint 100 | #define x_dinfo_zp Debug.dinfo_zprint 101 | #define x_winfo_pp Debug.winfo_pprint 102 | #define x_winfo_hp Debug.binfo_hprint 103 | cd inc#define x_winfo_zp Debug.binfo_zprint 104 | #define x_ninfo_hp (fun pr s p -> ()) 105 | #define x_ninfo_pp (fun s p -> ()) 106 | #define x_add 107 | #define x_add_1 108 | #define x_add_3 109 | #define x_noop 110 | #endif 111 | -------------------------------------------------------------------------------- /examples/minimal/.merlin: -------------------------------------------------------------------------------- 1 | B _build/** 2 | PKG ppx_polyprint -------------------------------------------------------------------------------- /examples/minimal/_tags: -------------------------------------------------------------------------------- 1 | true: package(ppx_polyprint ppx_deriving.show) 2 | <*.{cmo,native,byte}>: polyprint_native 3 | -------------------------------------------------------------------------------- /examples/minimal/main.ml: -------------------------------------------------------------------------------- 1 | 2 | open PolyPrint 3 | 4 | let () = 5 | print 1; 6 | print (fun x -> x); 7 | print (1, 2); 8 | print [1]; 9 | -------------------------------------------------------------------------------- /examples/minimal/makefile: -------------------------------------------------------------------------------- 1 | 2 | all: clean 3 | ocamlbuild -use-ocamlfind main.byte 4 | ./main.byte 5 | 6 | clean: 7 | ocamlbuild -clean 8 | rm -f *.byte 9 | -------------------------------------------------------------------------------- /examples/minimal/myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | 2 | open Ocamlbuild_plugin 3 | 4 | let () = 5 | dispatch ( 6 | function 7 | | After_rules -> 8 | flag ["ocaml"; "compile"; "polyprint_native"] & 9 | S [A "-ppx"; A "$(ocamlfind query ppx_polyprint)/ppx_polyprint"] 10 | | _ -> ()) 11 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | 2 | PACKAGE = ppx_polyprint 3 | LIB = PolyPrint 4 | TEST = test 5 | 6 | INSTALL = META \ 7 | _build/src/$(LIB).cmi \ 8 | _build/src/$(PACKAGE) \ 9 | _build/src/$(LIB).cma \ 10 | _build/src/$(LIB).cmxa \ 11 | _build/src/$(LIB).a 12 | 13 | OCB_FLAGS = -use-ocamlfind 14 | 15 | OCB = ocamlbuild $(OCB_FLAGS) 16 | 17 | .PHONY: all runtime ppx test examples doc clean 18 | 19 | all: runtime ppx 20 | 21 | runtime: 22 | $(OCB) $(LIB).cma 23 | $(OCB) $(LIB).cmxa 24 | 25 | ppx: 26 | $(OCB) $(PACKAGE).native 27 | cp $(PACKAGE).native _build/src/$(PACKAGE) 28 | 29 | test: all 30 | rm -rf _build/test/ 31 | $(OCB) test/$(TEST).byte 32 | ./$(TEST).byte --show-errors 33 | 34 | examples: up 35 | for d in examples/*/; do \ 36 | make -C $$d; \ 37 | done 38 | 39 | doc: 40 | $(OCB) -use-ocamlfind doc/api.docdir/index.html \ 41 | -docflags -t -docflag "API reference for $(PACKAGE)" \ 42 | -docflags '-colorize-code -short-functors -charset utf-8' \ 43 | -docflags '-css-style style.css' 44 | cp doc/style.css api.docdir/ 45 | 46 | clean: 47 | $(OCB) -clean 48 | rm -rf _tests 49 | rm -f *.byte 50 | for d in examples/*/; do \ 51 | make -C $$d clean; \ 52 | done 53 | 54 | # opam 55 | 56 | .PHONY: install remove up down 57 | 58 | install: all 59 | ocamlfind install $(PACKAGE) $(INSTALL) 60 | 61 | remove: 62 | ocamlfind remove $(PACKAGE) 63 | 64 | up: clean 65 | opam pin add $(PACKAGE) . -n -y 66 | opam install $(PACKAGE) -v -y 67 | 68 | down: 69 | opam remove $(PACKAGE) 70 | opam pin remove $(PACKAGE) 71 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | 2 | open Ocamlbuild_plugin 3 | 4 | let () = 5 | dispatch ( 6 | function 7 | | After_rules -> 8 | flag ["ocaml"; "compile"; "ppx_native"] & 9 | S [A "-ppx"; A "src/ppx_polyprint.native"] 10 | | _ -> ()) 11 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "ppx_polyprint" 3 | version: "0.0.0" 4 | maintainer: "Darius Foo " 5 | authors: "Darius Foo " 6 | homepage: "https://github.com/dariusf/ppx_polyprint" 7 | bug-reports: "https://github.com/dariusf/ppx_polyprint/issues" 8 | license: "MIT" 9 | dev-repo: "https://github.com/dariusf/ppx_polyprint" 10 | depends: [ 11 | "ocamlfind" 12 | "alcotest" { = "0.4.6" } 13 | "typpx" { = "1.1.2" } 14 | "ppx_tools" { = "4.02.3" } 15 | "ppx_deriving" { = "3.3" } 16 | "omake" { = "0.9.8.7" } 17 | ] 18 | install: [[make "install"]] 19 | remove: [[make "remove"]] 20 | build: [[make]] 21 | build-test: [make "test"] 22 | available: [ocaml-version = "4.02.3"] 23 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | 2 | This is an old project and has been superceded by [ppx_debug](https://github.com/dariusf/ppx_debug). 3 | 4 | # ppx_polyprint [![Build Status](https://travis-ci.org/dariusf/ppx_polyprint.svg)](https://travis-ci.org/dariusf/ppx_polyprint) 5 | 6 | A small library for convenient printf debugging and function tracing. 7 | 8 | Check out the [installation instructions](#installation). 9 | 10 | For more details, check out the [project report](report.pdf) or [slides](slides.pdf). 11 | 12 | ## Inspecting Values 13 | 14 | The API is exceedingly simple. Everything is contained in the module `PolyPrint`, which is suitable for opening at the top of a file. 15 | 16 | The eponymous function `print` is polymorphic in its only argument and prints a string representation of it to stdout. 17 | 18 | ```ocaml 19 | open PolyPrint 20 | 21 | print 1 22 | => 1 23 | 24 | print "true" 25 | => true 26 | 27 | print (false, 1) 28 | => (false, 1) 29 | ``` 30 | 31 | This may seem magical, but it's actually being replaced at compile-time with the appropriate monomorphic printer. 32 | 33 | `show` returns a string representation of a value. 34 | 35 | ```ocaml 36 | print_endline (show 1) 37 | => 1 38 | ``` 39 | 40 | `to_string` and `string_of` are aliases for `show`. 41 | 42 | `debug` is like `print`, but outputs a representation of its argument in addition to its value. 43 | 44 | ```ocaml 45 | let a = 1 in 46 | print_endline (debug (a + a * 2)) 47 | => a + a * 2: 3 48 | ``` 49 | 50 | ## Function Tracing 51 | 52 | This library also helps generate the boilerplate for function-level tracing. Let-bound functions annotated with `[@@trace]` or `[@@tracerec]` will have their inputs and output printed to stdout. 53 | 54 | ```ocaml 55 | let rec fact n = 56 | if n = 0 then 1 57 | else n * fact (n - 1) 58 | [@@tracerec] 59 | ``` 60 | 61 | Here's the default output of `fact 5` with `[@@tracerec]`, which tracks all recursive calls. 62 | 63 | ``` 64 | fact <- n = 5 65 | fact <- n = 4 66 | fact <- n = 3 67 | fact <- n = 2 68 | fact <- n = 1 69 | fact <- n = 0 70 | fact -> 1 71 | fact -> 1 72 | fact -> 2 73 | fact -> 6 74 | fact -> 24 75 | fact -> 120 76 | ``` 77 | 78 | The magic functions from earlier will be used to automatically figure out printer types. 79 | 80 | For some type `Module.t`, the printer that will be used is `Module.show_t`, following the conventions used by ppx_deriving. If this heuristic isn't sufficient, the printer name can be supplied manually (see below). 81 | 82 | Let-bindings in expression and structure context are annotated differently. 83 | 84 | ```ocaml 85 | (* structure item *) 86 | let plus x y = x + y 87 | [@@trace] 88 | 89 | (* expression *) 90 | let [@trace] plus x y = x + y in ... 91 | ``` 92 | 93 | Apart from using `@@` instead of `@`, structure annotations apply only to one specific binding when there are several (as opposed to expression annotations, which apply to all bindings). In the following snippet, both `plus` and `minus` will be traced. 94 | 95 | ```ocaml 96 | (* structure bindings may be annotated separately *) 97 | let plus x y = x + y 98 | [@@trace] 99 | and minus x y = x - y 100 | [@@trace] 101 | 102 | (* expression bindings may not *) 103 | let [@trace] plus x y = x + y 104 | and minus x y = x - y 105 | ``` 106 | 107 | ### Configuration 108 | 109 | `trace` and `tracerec` may be given parameters to customise how tracing is carried out. This forms a small DSL made of a sequence of expressions, each of which corresponding to an item or feature below. Multiple features can be enabled by separating them with `;`. For example, `[@trace Custom; x, y]`. 110 | 111 | #### Selectively tracing parameter values 112 | 113 | Sometimes the values of only certain parameters are interesting. Which these are may be specified using a tuple of identifiers. 114 | 115 | ```ocaml 116 | (* Only the first two arguments matter *) 117 | let triple x y z = x + y + 1 118 | [@@trace x, y] 119 | ``` 120 | 121 | If there no parameters specified, all parameters will be included, otherwise only the listed ones will be. 122 | 123 | Options can be associated with each identifier, for example, to override the printer to use. This is done by suffixing each identifier with a record. 124 | 125 | ```ocaml 126 | let triple x y z = (x, y, z) 127 | [@@trace x {printer = string_of_int}, y] 128 | ``` 129 | 130 | #### Hooking into the tracing process 131 | 132 | Parts of the tracing process may be selectively overridden by passing a module (containing an object, for open recursion) to `trace`. Here's a typical way to do this. 133 | 134 | ```ocaml 135 | open PolyPrint 136 | 137 | module Custom : TraceConfig = struct 138 | class api = object (self) 139 | inherit DefaultTraceConfig.api 140 | 141 | (* Your customisations here *) 142 | end 143 | let act = new api 144 | end 145 | 146 | let plus x y = x + y 147 | [@@trace Custom] 148 | ``` 149 | 150 | Refer to the signature of `TraceConfig` for API details and documentation on what may be tweaked. A high-level interface is available (for changing things like printing format), but lower-level control is also possible, allowing the customisation of details like where output goes, what information is added to recursive calls, etc. Examples of this may be found [here](examples/configs/src/config.ml). 151 | 152 | If you are using a build tool which automatically discovers module dependencies (`ocamldep`/`ocamlbuild`) and the configuration module is in another file, it needs to be referenced from somewhere other than the `[@trace]` annotation for it to be picked up as a dependency. Here's an easy way to ensure this. 153 | 154 | ```ocaml 155 | (* file: config.ml *) 156 | open PolyPrint 157 | 158 | module Custom : TraceConfig = struct 159 | include DefaultTraceConfig 160 | end 161 | ``` 162 | 163 | ```ocaml 164 | (* wherever else Custom is passed to [@trace] *) 165 | open Config 166 | 167 | let plus x y = x + y 168 | [@@trace Custom] 169 | ``` 170 | 171 | #### The default annotation 172 | 173 | If we are using the same configuration module across a file, it may be useful to specify it in one place, instead of in every annotation. The default annotation helps with this. 174 | 175 | ```ocaml 176 | [@@@polyprint Custom] 177 | ``` 178 | 179 | This will turn every `[@@trace]` annotation within a compilation unit into `[@@trace Custom]`. 180 | 181 | The default annotation supplies the module that call sites will use, if none is specified. Details [here](#call-site-information). 182 | 183 | #### Call site information 184 | 185 | The `call[n]` functions in `TraceConfig` allow us to intercept calls to traced functions. We may use this to record call site information (for example, where traced functions are called from), or even to modify semantics temporarily for debugging. 186 | 187 | Call sites are identified via a type system extension. Annotated functions are given a special internal type, `Traced`, which is isomorphic to a function arrow; it serves only to track whether a function is being traced. At call sites, `Traced` functions will be wrapped with `call[n]`. 188 | 189 | Traced functions require a configuration module to invoke `call[n]` on. The easiest way to specify this is via the default annotation. 190 | 191 | ```ocaml 192 | let id x = x 193 | [@@traced] 194 | 195 | [@@@polyprint Custom] 196 | 197 | id x 198 | ``` 199 | 200 | A more granular alternative is to annotate the *application* of a traced function. 201 | 202 | ```ocaml 203 | id x [@polyprint Custom] 204 | ``` 205 | 206 | Recursive, annotated functions invoke a `Traced` function as well (themselves!), and so their definitions may also be given a configuration module (only possible via the default annotation for now). 207 | 208 | The `call[n]` functions are given the file and line number in/at which the application occurred, to provide more information in huge logs. In the case of partial application, this is the point at which the function was *first* applied. 209 | 210 | **Caveat**: this feature currently does not interact well with Merlin, as Merlin's typechecker does not recognise `Traced` as a function type. The simplest way to get around this is to disable tracing for functions when it isn't needed (by commenting out the annotation). 211 | 212 | ## Installation 213 | 214 | `ppx_polyprint` is distributed as a findlib package. It is not yet on opam as it is still unstable, but it should build without much fuss if you want to try it out. 215 | 216 | Use a [container](Dockerfile) if you don't want to install this in your local opam repository. 217 | 218 | - Clone the repository 219 | - Pin the package, which will install dependencies and make the preprocessor available for use: 220 | 221 | ``` 222 | opam pin add ppx_polyprint . 223 | ``` 224 | 225 | - Try running the tests 226 | 227 | ``` 228 | make test 229 | ``` 230 | 231 | - Try running the examples with `make` 232 | 233 | ``` 234 | cd examples/minimal 235 | make 236 | ``` 237 | 238 | ### Usage 239 | 240 | - Include the runtime library. 241 | 242 | ``` 243 | # ocamlbuild 244 | true: package(ppx_polyprint) 245 | 246 | # otherwise, ensure this flag is passed to ocamlfind 247 | -package ppx_polyprint 248 | ``` 249 | 250 | - Register the ppx processor with `-ppx`. This is a temporary workaround for [a Merlin limitation](https://github.com/the-lambda-church/merlin/issues/483#issuecomment-182274832) and will be removed when the next version of Merlin is released. 251 | 252 | If you using `ocamlbuild`, add the following flags to `myocamlbuild.ml`: 253 | 254 | ```ocaml 255 | open Ocamlbuild_plugin 256 | 257 | let () = 258 | dispatch ( 259 | function 260 | | After_rules -> 261 | flag ["ocaml"; "compile"; "polyprint_native"] & 262 | S [A "-ppx"; A "$(ocamlfind query ppx_polyprint)/ppx_polyprint"] 263 | | _ -> ()) 264 | ``` 265 | 266 | ... then add the tag `polyprint_native` to your source files. 267 | 268 | ``` 269 | <*.{cmo,native,byte}>: polyprint_native 270 | ``` 271 | 272 | If you are not using `ocamlbuild`, pass the flag `-ppx $(ocamlfind query ppx_polyprint)/ppx_polyprint` to `ocamlfind`. 273 | 274 | ## Internals 275 | 276 | This project implements a specialised form of ad hoc polymorphism. 277 | 278 | It's difficult to implement a function with type `'a. 'a -> string` meaningfully without constraints on what `'a` may be. Thus, we simply default to something reasonable in polymorphic contexts. 279 | 280 | ```ocaml 281 | let stringify x = 282 | (* x has type 'a *) 283 | PolyPrint.to_string x 284 | 285 | stringify 1 286 | => 287 | ``` 288 | 289 | A more sophisticated scheme could be used (abstracting over polymorphic functions and lifting them out, to be specialised at call sites), but is not implemented. 290 | 291 | Typeclasses (see [ppx_implicits](https://bitbucket.org/camlspotter/ppx_implicits)) solve this problem in general. This is a specialisation of typeclasses that happens to be sufficient for printf debugging, and avoids the complexities of passing dictionaries in OCaml. Hopefully, modular implicits will someday obviate the need for this. 292 | 293 | This library is built on [TyPPX](https://bitbucket.org/camlspotter/typpx) and inherits its caveats: 294 | 295 | - It cannot be used in the toplevel, or in environments where program phrases are processed in isolation, as it requires access to the full typing environment of a program to insert printers. 296 | - It is sensitive to the order in which other ppx preprocessors are applied, as it requires a full picture of the typing environment. For example, it should be applied only after something like ppx_deriving, because references to ppx_deriving-generated functions would fail to typecheck if the latter hasn't already run. This is inconvenient because many build tools (ocamlfind, jbuilder) assume ppx processors to be independent of each other and don't allow control over the ordering. 297 | - It works only with a specific version of the compiler, 4.02.3. [Separate versions must be maintained](https://bitbucket.org/camlspotter/typpx/issues/3/porting-typpx-to-406) for other compilers. 298 | - Checking types during preprocessing introduces extra dependencies between modules (specifically, the cmi files of dependencies need to be present to preprocess a module). Newer build systems (jbuilder) compile files in parallel and do not support this. 299 | 300 | 301 | Other similar projects: 302 | 303 | - [ppx_show](https://github.com/diml/ppx_show) 304 | - [ocaml_at_p](https://github.com/tsubame-sp/ocaml_at_p) 305 | - [ppx_debugger](https://github.com/xvw/ppx_debugger) 306 | -------------------------------------------------------------------------------- /report.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dariusf/ppx_polyprint/6cd87e948a27888d251f851424ad8bd5545989ad/report.pdf -------------------------------------------------------------------------------- /slides.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dariusf/ppx_polyprint/6cd87e948a27888d251f851424ad8bd5545989ad/slides.pdf -------------------------------------------------------------------------------- /src/PPCoerce.ml: -------------------------------------------------------------------------------- 1 | 2 | open Typedtree 3 | open Types 4 | 5 | open PPUtil 6 | 7 | let too_many_args fn = 8 | failwith @@ Printf.sprintf "too many args given to %s!" (Untyped.show_expr fn) 9 | 10 | let interpret (attrs : Parsetree.attributes) = 11 | let open Parsetree in 12 | let open Asttypes in 13 | match attrs with 14 | | [] -> None 15 | | ({ txt = name }, Parsetree.PStr str) :: _ -> 16 | if name <> Names.default_annotation then None 17 | else 18 | let check item = 19 | match item with 20 | | { pstr_desc = Pstr_eval ({ 21 | pexp_desc = Pexp_construct ({ txt = path }, None)}, _) } -> 22 | [longident_to_list path] 23 | | _ -> [] 24 | in 25 | begin 26 | match List.map check str |> List.concat with 27 | | x :: _ -> Some x (* TODO consider all, not just first *) 28 | | _ -> None 29 | end 30 | | _ -> None 31 | 32 | (** Coerces a traced function into a regular function. 33 | TODO this is difficult to test, given the reliance on the type-checker closure.*) 34 | let coerce untyped typed arg_count attrs check = 35 | let constructor, _texprs = 36 | (* TODO try to factor out this part *) 37 | match typed.exp_type.desc with 38 | | Tconstr (path_t, texprs, abbrev) -> 39 | begin 40 | let name = 41 | let open Path in 42 | match path_t with 43 | | Pident { Ident.name; _ } -> Some name, texprs 44 | | Pdot (Pident { Ident.name = prefix; _ }, name, _) 45 | when prefix = "Pervasives" -> 46 | Some name, texprs 47 | (* TODO check that it comes from polyprint *) 48 | | Pdot (prefix, t, _) -> (* TODO *) 49 | Some t, texprs 50 | | _ -> failwith "Papply not yet implemented" 51 | in name 52 | end 53 | | _ -> None, [] 54 | in 55 | match constructor with 56 | | Some name when Names.is_traced_type name -> 57 | let arity = Names.traced_arity name in 58 | let untyped' = 59 | if arity < arg_count then 60 | too_many_args untyped 61 | else 62 | let loc = typed.exp_loc in 63 | let attr_name = interpret attrs in 64 | let config_module = 65 | match attr_name with 66 | | Some name -> name 67 | | _ -> otherwise 68 | [Names.runtime; Names.default_module] 69 | !PPEnv.specified_default_module in 70 | let wrapped = 71 | Untyped.app ~loc 72 | (Untyped.qualified_ident ~loc 73 | [Names.runtime; Names.wrap_n arity]) 74 | [Untyped.location loc; 75 | Untyped.pack ~loc 76 | config_module 77 | [Names.runtime; Names.default_module_sig]; 78 | untyped] [@metaloc loc] in 79 | 80 | if arity = arg_count then 81 | (* id 1 2 3 ==> (wrap id) 1 2 3 *) 82 | wrapped 83 | else 84 | (* id 1 2 ==> (fun a b c -> (wrap id) a b c) 1 2 *) 85 | Untyped.eta_abstract ~loc (arity - arg_count) wrapped 86 | in 87 | untyped', check untyped' 88 | | _ -> untyped, typed 89 | -------------------------------------------------------------------------------- /src/PPConfig.ml: -------------------------------------------------------------------------------- 1 | 2 | open Asttypes 3 | open Longident 4 | 5 | open PPUtil 6 | open PPUtil.Untyped 7 | open Parsetree 8 | 9 | type t = { 10 | module_prefix : string list; 11 | vars : (string) list 12 | } 13 | 14 | let rec list_of_sequence seq = 15 | match seq with 16 | | { pexp_desc = Pexp_sequence (e, f) } -> e :: list_of_sequence f 17 | | _ -> [seq] 18 | 19 | let default_config = { 20 | module_prefix = [Names.runtime; Names.default_module]; 21 | vars = []; 22 | } 23 | 24 | (** Indirection for getting the default module in the face of stateful 25 | configuration variables. Should be removed when this extension can be 26 | parameterised by it *) 27 | let default_module () = 28 | otherwise default_config.module_prefix !PPEnv.specified_default_module 29 | 30 | let rec interpret_one e config = 31 | match e with 32 | | { pexp_desc = Pexp_construct ({ txt = Lident name }, None) } -> 33 | (* a module *) 34 | { config with module_prefix = [name] } 35 | | { pexp_desc = Pexp_construct ({ txt = path }, None) } -> 36 | (* a qualified module *) 37 | { config with module_prefix = longident_to_list path } 38 | | { pexp_desc = Pexp_tuple ts } -> 39 | (* tuples are interchangeable with sequences for the most part, 40 | but sequences may not be nested inside them *) 41 | List.fold_right interpret_one ts config 42 | | { pexp_desc = Pexp_ident { txt = Lident name } } -> 43 | (* a variable name *) 44 | { config with vars = name :: config.vars } 45 | | _ -> config 46 | 47 | let interpret attrs = 48 | match attrs with 49 | | [] -> { default_config with module_prefix = default_module () } 50 | | x :: _ -> (* TODO consider all, not just first *) 51 | begin match x with 52 | | _, PStr [{pstr_desc = Pstr_eval (seq, _)}] -> 53 | let config_fields = list_of_sequence seq in 54 | List.fold_right interpret_one config_fields 55 | { default_config with module_prefix = default_module () } 56 | | _ -> { default_config with module_prefix = default_module () } 57 | end 58 | -------------------------------------------------------------------------------- /src/PPDriver.ml: -------------------------------------------------------------------------------- 1 | 2 | open Ast_mapper 3 | open Asttypes 4 | 5 | (** Code in this module is taken from Typpx's `make` and `compile` 6 | modules. It depends on the internals of both ocamlc and Typpx and 7 | should be considered fragile across different versions of both. *) 8 | 9 | module Compile = struct 10 | (* 11 | This is a modified version of driver/compile.ml of OCaml. 12 | *) 13 | [@@@ocaml.warning "-27"] 14 | 15 | (* The batch compiler *) 16 | 17 | open Format 18 | open Typedtree 19 | open Compenv 20 | 21 | module Make(Typemod : Typpx.S.Typemod)(TypedTransformation : Typpx.S.TypedTransformation) = struct 22 | 23 | (* Compile a .mli file *) 24 | 25 | (* Keep in sync with the copy in optcompile.ml *) 26 | 27 | let tool_name = "ocamlc" 28 | 29 | let interface ppf sourcefile outputprefix ast = 30 | Compmisc.init_path false; 31 | let modulename = module_of_filename ppf sourcefile outputprefix in 32 | Env.set_unit_name modulename; 33 | let initial_env = Compmisc.initial_env () in 34 | if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; 35 | if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast; 36 | let tsg = Typemod.type_interface initial_env ast in 37 | if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg; 38 | let sg = tsg.sig_type in 39 | if !Clflags.print_types then 40 | Printtyp.wrap_printing_env initial_env (fun () -> 41 | fprintf std_formatter "%a@." 42 | Printtyp.signature (Typemod.simplify_signature sg)); 43 | ignore (Includemod.signatures initial_env sg sg); 44 | Typecore.force_delayed_checks (); 45 | Warnings.check_fatal (); 46 | tsg 47 | 48 | (* Compile a .ml file *) 49 | 50 | let print_if ppf flag printer arg = 51 | if !flag then fprintf ppf "%a@." printer arg; 52 | arg 53 | 54 | let (++) x f = f x 55 | 56 | let implementation ppf sourcefile outputprefix ast = 57 | Compmisc.init_path false; 58 | let modulename = module_of_filename ppf sourcefile outputprefix in 59 | Env.set_unit_name modulename; 60 | let env = Compmisc.initial_env() in 61 | try 62 | let (typedtree, coercion) = 63 | ast 64 | ++ print_if ppf Clflags.dump_parsetree Printast.implementation 65 | ++ print_if ppf Clflags.dump_source Pprintast.structure 66 | ++ Typemod.type_implementation sourcefile outputprefix modulename env 67 | ++ print_if ppf Clflags.dump_typedtree 68 | Printtyped.implementation_with_coercion 69 | in 70 | if !Clflags.print_types then begin 71 | Warnings.check_fatal (); 72 | Stypes.dump (Some (outputprefix ^ ".annot")); 73 | end else begin 74 | Stypes.dump (Some (outputprefix ^ ".annot")); 75 | end; 76 | typedtree 77 | with x -> 78 | Stypes.dump (Some (outputprefix ^ ".annot")); 79 | raise x 80 | end 81 | end 82 | 83 | module Make = struct 84 | 85 | module Embed = struct 86 | (* e [@embed e'] => e' *) 87 | 88 | open Parsetree 89 | 90 | let extend super = 91 | let expr self e = match e.pexp_attributes with 92 | | [ {txt="typpx_embed"}, PStr [ { pstr_desc= Pstr_eval (e, []) } ] ] -> e 93 | | _ -> super.expr self e 94 | in 95 | { super with expr } 96 | 97 | let mapper = extend Ast_mapper.default_mapper 98 | 99 | end 100 | 101 | module F(A : sig 102 | val tool_name : string 103 | val args : (Arg.key * Arg.spec * Arg.doc) list 104 | val firstUntypedTransformation : mapper 105 | module Typemod : Typpx.S.Typemod 106 | module TypedTransformation : Typpx.S.TypedTransformation 107 | val lastUntypedTransformation : mapper 108 | end) = struct 109 | 110 | open A 111 | 112 | module Typecheck = Compile.Make(Typemod)(TypedTransformation) 113 | 114 | let dump_first = ref None 115 | let dump_untype = ref None 116 | 117 | let dump path ast = match path with 118 | | None -> () 119 | | Some path -> 120 | let oc = open_out path in 121 | let ppf = Format.formatter_of_out_channel oc in 122 | begin match ast with 123 | | `Str str -> Pprintast.structure ppf str 124 | | `Sig sg -> Pprintast.signature ppf sg 125 | end; 126 | Format.pp_print_newline ppf (); 127 | close_out oc 128 | 129 | let dump_str path str = dump path (`Str str); str 130 | let dump_sig path sg = dump path (`Sig sg); sg 131 | 132 | let rev_ppxs = ref [] 133 | let add_ppx s = rev_ppxs := s :: !rev_ppxs 134 | 135 | let dump_if_debug_mode exp = 136 | if !PPEnv.debug_mode then 137 | PPUtil.tap "Final output:" PPUtil.Untyped.print_structure exp 138 | else exp 139 | 140 | (* The PPX mapper *) 141 | 142 | let mapper = match Ast_mapper.tool_name () with 143 | | "ocamldep" -> 144 | (* If the tool is ocamldep, we CANNOT type-check *) 145 | firstUntypedTransformation 146 | | tool_name -> 147 | Clflags.all_ppx := List.rev !rev_ppxs; 148 | let structure _x str = 149 | Clflags.dont_write_files := true; 150 | Warnings.parse_options false "a"; (* print warning *) 151 | Warnings.parse_options true "a"; (* warning as error *) 152 | firstUntypedTransformation.structure firstUntypedTransformation str 153 | |> dump_str !dump_first 154 | |> Typecheck.implementation Format.err_formatter "papa" (* dummy *) "gaga" (* dummy *) 155 | |> TypedTransformation.map_structure 156 | |> Typpx.Untypeast.untype_structure 157 | |> dump_str !dump_untype 158 | |> Embed.mapper.structure Embed.mapper 159 | |> lastUntypedTransformation.structure lastUntypedTransformation 160 | |> dump_if_debug_mode 161 | |> Pparse.apply_rewriters_str ~tool_name 162 | in 163 | let signature _x sg = 164 | Clflags.dont_write_files := true; 165 | Warnings.parse_options false "a"; (* print warning *) 166 | Warnings.parse_options true "a"; (* warning as error *) 167 | firstUntypedTransformation.signature firstUntypedTransformation sg 168 | |> dump_sig !dump_first 169 | |> Typecheck.interface Format.err_formatter "papa" (* dummy *) "gaga" (* dummy *) 170 | |> TypedTransformation.map_signature 171 | |> Typpx.Untypeast.untype_signature 172 | |> dump_sig !dump_untype 173 | |> Embed.mapper.signature Embed.mapper 174 | |> lastUntypedTransformation.signature lastUntypedTransformation 175 | |> Pparse.apply_rewriters_sig ~tool_name 176 | in 177 | { default_mapper with structure; signature } 178 | 179 | let opts = 180 | let set_string_opt r = Arg.String (fun s -> r := Some s) in 181 | [( "-typpx-dump-first", set_string_opt dump_first, ": (TyPPX) Dump the result of the first untyped transformation stage" ); 182 | ( "-typpx-dump-untype", set_string_opt dump_untype, ": (TyPPX) Dump the result of the untype stage" ); 183 | ( "-ppx", Arg.String add_ppx, ": (TyPPX) Run extra PPX preprocessing at the final phase of TyPPX" ); 184 | ] 185 | 186 | let run () = Ppxx.Ppx.run (args @ opts) tool_name (fun () -> ()) mapper 187 | end 188 | end 189 | -------------------------------------------------------------------------------- /src/PPEnv.ml: -------------------------------------------------------------------------------- 1 | 2 | (** Information passed across traversals *) 3 | 4 | (** Configuration module path provided for each function name *) 5 | module NameConfigMap = Map.Make(String) 6 | let configuration_modules = ref (NameConfigMap.empty : string list NameConfigMap.t) 7 | 8 | (** The default module to use if not explicitly given *) 9 | let specified_default_module = ref (None : string list option) 10 | 11 | let debug_mode = ref false 12 | 13 | let check_debug_mode () = 14 | try 15 | ignore @@ Sys.getenv "POLYPRINT_DEBUG"; 16 | debug_mode := true 17 | with Not_found -> () 18 | 19 | let init () = 20 | check_debug_mode () 21 | -------------------------------------------------------------------------------- /src/PPShow.ml: -------------------------------------------------------------------------------- 1 | 2 | open Ast_mapper 3 | open Ast_helper 4 | open Asttypes 5 | open Longident 6 | open Typedtree 7 | 8 | open PPUtil 9 | open PPUtil.Typed 10 | 11 | let constant_pp primitive = 12 | match primitive with 13 | | "string" -> tident_ ["Format"; "pp_print_string"] 14 | | "int" -> tident_ ["Format"; "pp_print_int"] 15 | | "bool" -> tident_ ["Format"; "pp_print_bool"] 16 | | "char" -> tident_ ["Format"; "pp_print_char"] 17 | | "float" -> tident_ ["Format"; "pp_print_float"] 18 | | "int32" -> tapp (qualified "pp_int32") [] 19 | | "int64" -> tapp (qualified "pp_int64") [] 20 | | "nativeint" -> tapp (qualified "pp_nativeint") [] 21 | | "exn" -> tapp (qualified "pp_exc") [] 22 | | "unit" -> tapp (qualified "pp_unit") [] 23 | | _ -> failwith @@ "printer for primitive type " ^ primitive ^ " not implemented" 24 | 25 | (** Given the type and value of a function argument, reconstruct the printer for it.*) 26 | let rec build_pp : Types.type_expr -> expression option -> expression = 27 | fun ty arg -> 28 | let open Types in 29 | match ty.desc with 30 | | Tconstr (path_t, texprs, abbrev) -> 31 | begin 32 | let name = 33 | let open Path in 34 | match path_t with 35 | | Pident { Ident.name; _ } -> 36 | begin match name with 37 | | ("int" | "string" | "bool" | "char" | "float" | "unit" | 38 | "exn" | "int32" | "int64" | "nativeint") as name -> 39 | constant_pp name 40 | | ("list" | "option" | "ref") -> 41 | tapp (qualified ("pp_" ^ name)) 42 | (List.map (fun t -> build_pp t None) texprs) 43 | | t -> 44 | tapp (tident ("pp_" ^ t)) 45 | (List.map (fun t -> build_pp t None) texprs) 46 | end 47 | | Pdot (Pident { Ident.name = prefix; _ }, name, _) when prefix = "Pervasives"-> 48 | build_pp { ty with desc = Tconstr (pident name, texprs, abbrev) } arg 49 | | Pdot (prefix, t, _) -> 50 | tapp (tident_with_path prefix ("pp_" ^ t)) 51 | (List.map (fun t -> build_pp t None) texprs) 52 | | _ -> failwith "Papply not yet implemented" 53 | in name 54 | end 55 | | Tarrow _ -> 56 | begin match arg with 57 | | None -> qualified "pp_function" 58 | | Some a -> 59 | let repr = truncate 20 (show_expr a) ^ " : " ^ show_type ty in 60 | tapp (qualified "pp_function_rep") [tstr repr] 61 | end 62 | | Ttuple tys -> 63 | let length = List.length tys in 64 | assert (length >= 2 && length <= 7); 65 | let suffix = if length = 2 then "" else string_of_int length in 66 | let name = "pp_tuple" ^ suffix in 67 | tapp (qualified name) (List.map (fun t -> build_pp t None) tys) 68 | | Tlink t -> build_pp t arg 69 | | Tvar v -> (* v is a monomorphic type variable *) 70 | begin 71 | match v with 72 | | Some v -> 73 | tapp (qualified "pp_tvar") [tstr v] 74 | | None -> 75 | tapp (qualified "pp_tvar") [tstr ""] 76 | end 77 | | Tobject (t, _) -> 78 | tapp (qualified "pp_misc") [tstr (show_type t)] 79 | | Tfield _ -> failwith "not implemented field" 80 | | Tnil -> failwith "not implemented nil" 81 | | Tsubst _ -> failwith "not implemented subst" 82 | | Tvariant _ -> failwith "not implemented variant" 83 | | Tunivar _ -> failwith "not implemented univar" 84 | | Tpoly _ -> failwith "not implemented poly" 85 | | Tpackage _ -> failwith "not implemented pkg" 86 | 87 | let transform_printer e args = 88 | let open Types in 89 | let arg_count = List.length args in 90 | let arg_exprs = args_to_exprs args in 91 | begin match arg_exprs with 92 | | [] -> 93 | (* printers must be used in a higher-order context *) 94 | begin match e.exp_desc with 95 | | Texp_ident (_, _, { val_type = ty }) -> 96 | begin match ty.desc with 97 | | Tarrow (_, a, b, _) -> 98 | let printer = 99 | tapp (tident_ ["Format"; "asprintf"]) [tstr "%a"; build_pp a None] in 100 | { e with exp_desc = printer.exp_desc } 101 | | _ -> assert false 102 | end 103 | 104 | | _ -> assert false (* better error handling required *) 105 | end 106 | 107 | | [{ exp_type = ty } as arg] -> 108 | (* printers are called with a single argument *) 109 | let printer = 110 | tapp (tident_ ["Format"; "asprintf"]) ([tstr "%a"; 111 | build_pp ty (Some arg)] @ [arg]) in 112 | { e with exp_desc = printer.exp_desc } 113 | | _ -> 114 | (* better error handling required *) 115 | failwith (Printf.sprintf "no function in the API has %d arguments" arg_count) 116 | end 117 | 118 | module TypedTransform : TypedtreeMap.MapArgument = struct 119 | include TypedtreeMap.DefaultMapArgument 120 | 121 | let rec implementations name fn args = 122 | if List.mem name Names.to_string then 123 | transform_printer fn args 124 | else if name = Names.print then 125 | tapp (tident "print_endline") [transform_printer fn args] 126 | else if name = Names.debug then 127 | let stringified = 128 | args |> args_to_exprs |> List.map show_expr |> String.concat ", " 129 | in 130 | tapp (tident_ ["Printf"; "printf"]) 131 | [tstr "%s: %s\n"; tstr stringified; 132 | implementations (List.hd Names.to_string) fn args] 133 | else fn 134 | 135 | let enter_expression e = 136 | let open Path in 137 | match e.exp_desc with 138 | | Texp_apply 139 | ({exp_desc = 140 | Texp_ident (Pdot (Pident {Ident.name = mod_name}, fn_name, _), _loc, _) }, args) 141 | when mod_name = Names.runtime -> 142 | implementations fn_name e args 143 | | Texp_ident (Pdot (Pident {Ident.name = mod_name}, fn_name, _), _loc, _) 144 | when mod_name = Names.runtime -> 145 | implementations fn_name e [] 146 | | _ -> e 147 | 148 | let leave_expression e = e 149 | end 150 | 151 | (* TODO factor out *) 152 | let pat_var name = 153 | let open Parsetree in 154 | { ppat_desc = Ppat_var { txt = name; loc = dummy_loc }; 155 | ppat_loc = dummy_loc; 156 | ppat_attributes = [] } 157 | 158 | let app f args = 159 | Exp.apply f (List.map (fun a -> "", a) args) 160 | 161 | let ident s = 162 | Exp.ident { txt = Lident s; loc = dummy_loc } 163 | 164 | (** Eta-abstraction uses of library functions in identifier position only *) 165 | let eta_abstraction_mapper = 166 | let open Parsetree in 167 | { default_mapper with 168 | expr = begin 169 | fun mapper expr -> 170 | match expr.pexp_desc with 171 | | Pexp_apply 172 | ({ pexp_desc = 173 | Pexp_ident ({ txt = Ldot (Lident mod_name, _) }) } as f, args) 174 | when mod_name = Names.runtime -> 175 | 176 | { expr with 177 | pexp_desc = Pexp_apply 178 | (f, List.map (fun (l, a) -> l, mapper.expr mapper a) args) } 179 | 180 | | Pexp_ident ({ txt = Ldot (Lident mod_name, _) }) 181 | when mod_name = Names.runtime -> 182 | 183 | (* TODO try to replace pat_var and these patterns with metaquot *) 184 | (* TODO factor this out and replace with eta_abstract *) 185 | { expr with pexp_desc = Pexp_fun ("", None, pat_var "x", app expr [ident "x"]) } 186 | 187 | | _ -> default_mapper.expr mapper expr 188 | end; 189 | structure_item = fun mapper item -> 190 | match item with 191 | | { pstr_desc = Pstr_value (rec_flag, bindings) } -> 192 | (* Recurse into nested subexpressions *) 193 | let new_bindings = List.map 194 | (fun vb -> { vb with pvb_expr = mapper.expr mapper vb.pvb_expr }) 195 | bindings in 196 | { item with pstr_desc = Pstr_value (rec_flag, new_bindings) } 197 | | s -> default_mapper.structure_item mapper s 198 | } 199 | -------------------------------------------------------------------------------- /src/PPTrace.ml: -------------------------------------------------------------------------------- 1 | 2 | open Ast_mapper 3 | open Ast_helper 4 | open Asttypes 5 | open Longident 6 | open Parsetree 7 | 8 | open PPUtil 9 | open PPUtil.Untyped 10 | 11 | (** Given a binding, pulls out the relevant fields. 12 | Also collects information to add to the environment. *) 13 | let extract_binding_info config b = 14 | let { pvb_pat = original_lhs; pvb_expr = original_rhs } = b in 15 | let fn_name = get_fn_name original_lhs in 16 | let params = collect_params original_rhs in 17 | 18 | (* Collect information *) 19 | let open PPEnv in 20 | configuration_modules := 21 | NameConfigMap.add fn_name config.PPConfig.module_prefix !configuration_modules; 22 | 23 | (original_rhs, fn_name, params) 24 | 25 | (** Ensures that there are not too many parameters. Warns if 26 | that is the case. *) 27 | let count_params fn_name params = 28 | let actual = List.length params in 29 | let clamped = clamp 0 7 actual in 30 | if clamped <> actual then Errors.warn_too_many_params fn_name actual; 31 | clamped 32 | 33 | (** We only take parameters within the list, but if it is empty, 34 | we don't filter at all. *) 35 | let filter_params interesting params = 36 | match interesting with 37 | | [] -> params 38 | | _ -> 39 | let p = function 40 | | Unit -> true 41 | | Param p -> List.mem p interesting 42 | in 43 | List.filter p params 44 | 45 | let check_all_occur_in given actual = 46 | let check (name, inside) = 47 | if not inside then 48 | Printf.sprintf "%s is not a valid parameter (expecting one of %s)" 49 | name (string_of_list show_param actual) 50 | |> failwith 51 | in 52 | List.map (fun x -> List.mem (Param x) actual) given 53 | |> zip given |> List.iter check 54 | 55 | (** Generates the invocation which actually runs the function being traced. *) 56 | let run_invocation ~loc fn_name params config fn = 57 | check_all_occur_in config.PPConfig.vars params; 58 | let filtered_params = filter_params config.PPConfig.vars params in 59 | let filtered_param_count = List.length filtered_params in 60 | assert (filtered_param_count <= List.length params); 61 | let run_fn_ident = 62 | Exp.send ~loc 63 | (qualified_ident ~loc (config.PPConfig.module_prefix @ [Names.config_obj])) 64 | (Names.run_n filtered_param_count) in 65 | let final_fn = 66 | if filtered_param_count = List.length params 67 | then fn 68 | else 69 | fun_wildcards ~loc 70 | filtered_param_count 71 | (app ~loc fn (List.map (param_to_expr ~loc) params)) in 72 | let invocation = app ~loc run_fn_ident (List.concat [ 73 | [str ~loc fn_name]; 74 | List.map (fun p -> Exp.tuple ~loc [ 75 | str ~loc (show_param p); 76 | [%expr PolyPrint.show]; 77 | param_to_expr ~loc p 78 | ]) filtered_params; 79 | [[%expr PolyPrint.show]]; 80 | [final_fn]]) [@metaloc loc] 81 | in 82 | invocation 83 | 84 | let traced_fn ~loc arity f = 85 | let name = Names.traced_n arity in 86 | Exp.construct ~loc ({ txt = Ldot (Lident Names.runtime, name); loc }) (Some f) 87 | 88 | let transform_binding_recursively config b = 89 | let original_rhs, fn_name, params = extract_binding_info config b in 90 | let arity = count_params fn_name params in 91 | let nonrec_body, loc = 92 | let nonrec_params = Param (Names.self fn_name) :: params in 93 | let body, loc = get_fn_body original_rhs in 94 | let mapper = app_mapper fn_name (Names.self fn_name) in 95 | let new_body = mapper.expr mapper body in 96 | fun_with_params ~loc nonrec_params new_body, loc 97 | in 98 | let new_rhs = traced_fn ~loc arity @@ fun_with_params ~loc params [%expr 99 | let [%p pat_var (Names.mangle fn_name)] = [%e nonrec_body] in 100 | let rec aux = 101 | [%e traced_fn ~loc arity @@ fun_with_params ~loc params 102 | (run_invocation ~loc fn_name params config 103 | (app ~loc (ident (Names.mangle fn_name)) 104 | [eta_abstract ~loc arity (ident ~loc "aux")])) 105 | ] in [%e app_variables ~loc "aux" params] 106 | ] [@metaloc loc] in 107 | { b with pvb_expr = new_rhs } 108 | 109 | let transform_binding_nonrecursively config b = 110 | let original_rhs, fn_name, params = extract_binding_info config b in 111 | let arity = count_params fn_name params in 112 | let new_rhs, loc = 113 | let body, loc = get_fn_body original_rhs in 114 | let mapper = app_mapper fn_name (Names.mangle fn_name) in 115 | let new_body = mapper.expr mapper body in 116 | fun_with_params ~loc params new_body, loc 117 | in 118 | (* let rec is used here when transforming recursive functions. 119 | Non-recursive functions wouldn't have recursive references, 120 | so this is safe. *) 121 | let new_rhs' = traced_fn ~loc arity @@ fun_with_params ~loc params [%expr 122 | let rec [%p pat_var (Names.mangle fn_name)] = [%e new_rhs] in 123 | [%e run_invocation ~loc fn_name params config 124 | (ident (Names.mangle fn_name))]] [@metaloc loc] 125 | in 126 | { b with pvb_expr = new_rhs' } 127 | 128 | let transform_recursive_binding attrs b = 129 | let config = PPConfig.interpret attrs in 130 | if any (has_attr "tracerec") attrs then 131 | transform_binding_recursively config b 132 | else 133 | transform_binding_nonrecursively config b 134 | 135 | let transform_nonrecursive_binding attrs b = 136 | let config = PPConfig.interpret attrs in 137 | transform_binding_nonrecursively config b 138 | 139 | let interesting_expr_binding rec_flag attrs binding = 140 | let has_attribute = 141 | match rec_flag with 142 | | Nonrecursive -> 143 | if any (has_attr "tracerec") attrs then 144 | Errors.tracerec_used_on_nonrecursive_binding () 145 | else 146 | any (has_attr "trace") attrs 147 | | Recursive -> 148 | any (has_attr "trace") attrs || any (has_attr "tracerec") attrs 149 | in has_attribute && is_function_binding binding 150 | 151 | let interesting_str_binding rec_flag binding = 152 | let attrs = binding.pvb_attributes in 153 | interesting_expr_binding rec_flag attrs binding 154 | 155 | let transform_expr rec_flag transform expr mapper bindings body = 156 | let change b = 157 | if interesting_expr_binding rec_flag expr.pexp_attributes b then 158 | transform expr.pexp_attributes b 159 | else 160 | { b with pvb_expr = mapper.expr mapper b.pvb_expr } 161 | in 162 | let new_bindings = List.map change bindings in 163 | { expr with pexp_desc = Pexp_let (rec_flag, new_bindings, mapper.expr mapper body) } 164 | 165 | let transform_str rec_flag transform mapper bindings = 166 | let change b = 167 | if interesting_str_binding rec_flag b then 168 | transform b.pvb_attributes b 169 | else 170 | { b with pvb_expr = mapper.expr mapper b.pvb_expr } 171 | in 172 | let new_bindings = List.map change bindings in 173 | item @@ Pstr_value (rec_flag, new_bindings) 174 | 175 | let check_for_annotation item = 176 | match item with 177 | | { pstr_desc = Pstr_attribute ({ txt = name }, PStr str_inputs) } 178 | when name = Names.default_annotation -> 179 | let check item = 180 | match item with 181 | | { pstr_desc = Pstr_eval ({ 182 | pexp_desc = Pexp_construct ({ txt = path }, None)}, _) } -> 183 | (* TODO if there are multiple specified, which does this use? *) 184 | PPEnv.specified_default_module := Some (longident_to_list path) 185 | | _ -> () 186 | in 187 | List.iter check str_inputs; 188 | | _ -> () 189 | 190 | (** A mapper that generates tracing boilerplate for annotated functions. 191 | The traversal is also used to collect information to build up the environment 192 | for future traversals. *) 193 | let annotation_mapper = 194 | { default_mapper with 195 | expr = 196 | begin 197 | fun mapper expr -> 198 | match expr with 199 | | { pexp_desc = Pexp_let (rec_flag, bindings, body) } -> 200 | begin 201 | match rec_flag with 202 | | Recursive -> 203 | transform_expr Recursive 204 | transform_recursive_binding expr mapper bindings body 205 | | Nonrecursive -> 206 | transform_expr Nonrecursive 207 | transform_nonrecursive_binding expr mapper bindings body 208 | end 209 | | x -> default_mapper.expr mapper x; 210 | end; 211 | structure_item = fun mapper item -> 212 | check_for_annotation item; 213 | match item with 214 | | { pstr_desc = Pstr_value (rec_flag, bindings) } -> 215 | begin 216 | match rec_flag with 217 | | Recursive -> 218 | transform_str Recursive 219 | transform_recursive_binding mapper bindings 220 | | Nonrecursive -> 221 | transform_str Nonrecursive 222 | transform_nonrecursive_binding mapper bindings 223 | end 224 | | s -> default_mapper.structure_item mapper s 225 | } 226 | 227 | -------------------------------------------------------------------------------- /src/PPUtil.ml: -------------------------------------------------------------------------------- 1 | 2 | open Ast_mapper 3 | open Asttypes 4 | open Longident 5 | 6 | module Names = struct 7 | open Printf 8 | open Str 9 | 10 | let runtime = "PolyPrint" 11 | let printers = "Printers" 12 | let default_annotation = "polyprint" 13 | let default_module = "DefaultTraceConfig" 14 | let default_module_sig = "TraceConfig" 15 | let to_string = ["to_string"; "string_of"; "show"] 16 | let print = "print" 17 | let debug = "debug" 18 | let config_obj = "act" 19 | let run_n n = "run" ^ string_of_int n 20 | let call_n n = "call" ^ string_of_int n 21 | let traced_n n = "Traced" ^ string_of_int n 22 | let traced_type_n n = "traced" ^ string_of_int n 23 | let traced_arity name = 24 | try 25 | ignore @@ search_forward (regexp "traced\\([0-7]\\)") name 0; 26 | matched_group 1 name |> int_of_string 27 | with Not_found -> 28 | printf "%s is not a valid name for a traced function type" name; 29 | raise Not_found 30 | 31 | let is_traced_type name = 32 | try 33 | ignore @@ traced_arity name; true 34 | with Not_found -> false 35 | 36 | let wrap_n n = "wrap" ^ string_of_int n 37 | let mangle fn_name = fn_name ^ "_original" 38 | let self name = name ^ "_self" 39 | let unself name = 40 | let length = String.length name in 41 | if length < 5 then name 42 | else String.sub name 0 (length - 5) 43 | end 44 | 45 | module Errors = struct 46 | let tracerec_used_on_nonrecursive_binding () = 47 | failwith @@ Printf.sprintf "[@tracerec] cannot be used on a non-recursive binding" 48 | 49 | let warn_too_many_params = 50 | Printf.printf "Warning: %s was given %d arguments but this library only supports up to 7.\n" 51 | end 52 | 53 | let all f xs = 54 | List.fold_left (fun t c -> t && f c) true xs 55 | 56 | let any f xs = 57 | List.fold_left (fun t c -> t || f c) false xs 58 | 59 | let push x xs = 60 | xs := x :: !xs 61 | 62 | let clear xs = 63 | xs := [] 64 | 65 | let clamp l h x = 66 | max l (min h x) 67 | 68 | let rec range l u = 69 | if l = u then [] 70 | else l :: range (l + 1) u 71 | 72 | let otherwise default e = 73 | match e with 74 | | None -> default 75 | | Some x -> x 76 | 77 | let rec zip xs ys = 78 | match xs, ys with 79 | | [], _ | _, [] -> [] 80 | | x :: xs, y :: ys -> 81 | (x, y) :: zip xs ys 82 | 83 | let id x = x 84 | 85 | let string_of_list pr xs = 86 | let rec aux xs = 87 | match xs with 88 | | [] -> "" 89 | | [x] -> pr x 90 | | y :: ys -> pr y ^ "; " ^ aux ys 91 | in "[" ^ aux xs ^ "]" 92 | 93 | let replace needle haystack = 94 | Str.global_replace (Str.regexp needle) haystack 95 | 96 | let starts_with prefix s = 97 | try 98 | ignore (Str.search_forward (Str.regexp prefix) s 0); 99 | true 100 | with Not_found -> false 101 | 102 | let truncate n s = 103 | if String.length s <= n then s 104 | else String.sub s 0 n ^ "..." 105 | 106 | let tap msg action x = 107 | print_string @@ msg ^ " "; 108 | action x; 109 | x 110 | 111 | let taps msg x = 112 | print_endline msg; 113 | x 114 | 115 | let dummy_loc = { 116 | Location.loc_start = Lexing.dummy_pos; 117 | Location.loc_end = Lexing.dummy_pos; 118 | Location.loc_ghost = true 119 | } 120 | 121 | let to_longident p = 122 | let rec aux p = 123 | match p with 124 | | [] -> assert false 125 | | [x] -> Lident x 126 | | x :: xs -> Ldot (aux xs, x) 127 | in aux (List.rev p) 128 | 129 | let rec longident_to_list li = 130 | match li with 131 | | Lident name -> [name] 132 | | Ldot (a, b) -> longident_to_list a @ [b] 133 | | Lapply _ -> failwith "longident apply cannot be converted" 134 | 135 | module Untyped = struct 136 | 137 | open Ast_helper 138 | open Parsetree 139 | 140 | let show_structure = Pprintast.string_of_structure 141 | 142 | let print_structure e = 143 | show_structure e |> print_endline 144 | 145 | let show_expr = Pprintast.string_of_expression 146 | 147 | let print_expr e = 148 | show_expr e |> print_endline 149 | 150 | let app ?(loc=dummy_loc) f args = 151 | Exp.apply ~loc f (List.map (fun a -> "", a) args) 152 | 153 | let ident ?(loc=dummy_loc) s = 154 | Exp.ident ~loc { txt = Lident s; loc } 155 | 156 | let str ?(loc=dummy_loc) s = 157 | Exp.constant ~loc (Const_string (s, None)) 158 | 159 | let qualified_ident ?(loc=dummy_loc) ss = 160 | match ss with 161 | | [] -> failwith "qualified_ident requires a non-empty list" 162 | | [s] -> ident ~loc s 163 | | s :: ss -> 164 | let res = List.fold_left (fun t c -> Ldot (t, c)) (Lident s) ss in 165 | Exp.ident ~loc { txt = res; loc } 166 | 167 | let pack ?(loc=dummy_loc) module_name sig_name = 168 | Exp.constraint_ ~loc 169 | (Exp.pack ~loc { 170 | pmod_desc = Pmod_ident { txt = to_longident module_name; loc }; 171 | pmod_loc = loc; 172 | pmod_attributes = [] 173 | }) (Typ.package ~loc ({ txt = to_longident sig_name; loc }) []) 174 | 175 | let is_function_binding b = 176 | match b with 177 | | { pvb_expr = { pexp_desc = Pexp_fun _ } } -> true 178 | | _ -> false 179 | 180 | let get_fn_name pat = 181 | match pat with 182 | | { ppat_desc = Ppat_var { txt = fn_name }; _ } -> fn_name 183 | | _ -> failwith "not a function pattern" 184 | 185 | (** Recurses down a curried lambda to get the body *) 186 | let rec get_fn_body ?(loc=dummy_loc) pexp = 187 | match pexp with 188 | | { pexp_desc = Pexp_fun (_, _, _, b); pexp_loc } -> get_fn_body ~loc:pexp_loc b 189 | | _ -> pexp, loc 190 | 191 | let pat_any = { 192 | ppat_desc = Ppat_any; 193 | ppat_loc = dummy_loc; 194 | ppat_attributes = [] 195 | } 196 | 197 | let pat_var name = { 198 | ppat_desc = Ppat_var { txt = name; loc = dummy_loc }; 199 | ppat_loc = dummy_loc; 200 | ppat_attributes = [] 201 | } 202 | 203 | let pat_unit = { 204 | ppat_desc = Ppat_construct ({ txt = Lident "()"; loc = dummy_loc }, None); 205 | ppat_loc = dummy_loc; 206 | ppat_attributes = [] 207 | } 208 | 209 | type param = Param of string | Unit 210 | 211 | let show_param p = 212 | match p with 213 | | Unit -> "()" 214 | | Param x -> x 215 | 216 | let rec collect_params f = 217 | match f with 218 | | { pexp_desc = Pexp_fun (_, _, { ppat_desc = desc; _ }, rest ) } -> 219 | begin match desc with 220 | | Ppat_var { txt = param; _ } 221 | | Ppat_constraint ({ ppat_desc = Ppat_var { txt = param; _ } }, _) -> 222 | Param param :: collect_params rest 223 | | Ppat_construct ({txt = Lident "()"}, None) -> 224 | Unit :: collect_params rest 225 | | _ -> [] 226 | end 227 | | _ -> [] 228 | 229 | let param_to_expr ?(loc=dummy_loc) p = 230 | match p with 231 | | Unit -> Exp.construct ~loc ({ txt = Lident "()"; loc }) None 232 | | Param name -> Exp.ident ~loc { txt = Lident name; loc } 233 | 234 | let param_to_arg ?(loc=dummy_loc) p = 235 | "", param_to_expr ~loc p 236 | 237 | let app_variables ?(loc=dummy_loc) f args = 238 | Exp.apply ~loc (ident ~loc f) (List.map (param_to_arg ~loc) args) 239 | 240 | let rec fun_with_params ?(loc=dummy_loc) params body = 241 | match params with 242 | | [] -> body 243 | | p :: ps -> 244 | let p' = 245 | match p with 246 | | Param x -> pat_var x 247 | | Unit -> pat_unit 248 | in Exp.fun_ ~loc "" None p' (fun_with_params ~loc ps body) 249 | 250 | let rec eta_abstract ?(loc=dummy_loc) n exp = 251 | let make_param s = Param ("_" ^ string_of_int s) in 252 | let params = range 0 n |> List.map make_param in 253 | fun_with_params ~loc params 254 | (Exp.apply ~loc exp (params |> List.map (param_to_arg ~loc))) 255 | 256 | (* Returns a lambda with n wildcard parameters, e.g. fun _ _ -> body *) 257 | let rec fun_wildcards ?(loc=dummy_loc) n body = 258 | match n with 259 | | 0 -> body 260 | | _ -> Exp.fun_ ~loc "" None pat_any (fun_wildcards ~loc (n - 1) body) 261 | 262 | let location loc = 263 | Exp.tuple ~loc [ 264 | Exp.ident ~loc { txt = Lident "__FILE__"; loc }; 265 | Exp.ident ~loc { txt = Lident "__LINE__"; loc } 266 | ] 267 | 268 | let item desc = { 269 | pstr_desc = desc; 270 | pstr_loc = dummy_loc; 271 | } 272 | 273 | let app_mapper find replace = 274 | { default_mapper with 275 | expr = fun mapper expr -> 276 | match expr with 277 | | { pexp_desc = 278 | Pexp_apply 279 | ({ pexp_desc = Pexp_ident { txt = Lident fn_name; loc } }, args) } 280 | when fn_name = find -> 281 | Exp.apply ~loc (Exp.ident ~loc { txt = Lident replace; loc }) args 282 | | { pexp_desc = 283 | Pexp_apply 284 | ({ pexp_desc = Pexp_ident { txt = Ldot (initial, fn_name); loc } }, args) } 285 | when fn_name = find -> 286 | Exp.apply ~loc (Exp.ident ~loc { txt = Ldot (initial, replace); loc }) args 287 | | _ -> default_mapper.expr mapper expr 288 | } 289 | 290 | let has_attr name attr = 291 | match attr with 292 | | { txt = n }, _ when n = name -> true 293 | | _ -> false 294 | 295 | end 296 | 297 | module Typed = struct 298 | 299 | open Typedtree 300 | 301 | let pident name = Path.Pident { Ident.name = name; stamp = 0; flags = 0 } 302 | 303 | let pdot t name = Path.Pdot (t, name, 0) 304 | 305 | (* let failure loc = *) 306 | (* raise *) 307 | (* (Location.Error *) 308 | (* (Location.error ~loc "[%pretty] accepts a string, e.g. [%pretty \"USER\"]")) *) 309 | 310 | let dummy_value_desc = 311 | Types.{ 312 | val_type = { level = 0; id = 0; desc = Tnil }; 313 | val_kind = Val_reg; 314 | val_loc = dummy_loc; 315 | val_attributes = []; 316 | } 317 | 318 | let dummy_type = 319 | Types.{ 320 | desc = Tvar (Some ""); 321 | level = 0; 322 | id = 0; 323 | } 324 | 325 | let expr_from_desc ?(loc=dummy_loc) desc = 326 | { 327 | exp_desc = desc; 328 | exp_loc = loc; 329 | exp_extra = []; 330 | exp_type = dummy_type; 331 | exp_env = Env.empty; 332 | exp_attributes = []; 333 | } 334 | 335 | let dummy_args args = 336 | List.map (fun a -> "", Some a, Required) args 337 | 338 | let string_desc s = 339 | Texp_constant (Const_string (s, None)) 340 | 341 | let tstr s = 342 | expr_from_desc (string_desc s) 343 | 344 | let print_ident { Ident.stamp=stamp; Ident.name=name; Ident.flags=flags } = 345 | (* "{stamp=" ^ string_of_int stamp ^ " name=" ^ name ^ " flags=" ^ string_of_int flags ^ "}" *) 346 | name 347 | 348 | (* Printtyp.string_of_path *) 349 | 350 | let to_path p = 351 | let rec aux p = 352 | match p with 353 | | [] -> assert false 354 | | [x] -> pident x 355 | | x :: xs -> pdot (aux xs) x 356 | in aux (List.rev p) 357 | 358 | let tident name = 359 | expr_from_desc @@ Texp_ident ( 360 | pident name, { 361 | txt = Lident name; 362 | loc = dummy_loc 363 | }, 364 | dummy_value_desc) 365 | 366 | let tident_ qname = 367 | expr_from_desc @@ Texp_ident ( 368 | to_path qname, { 369 | txt=to_longident qname; 370 | loc=dummy_loc 371 | }, 372 | dummy_value_desc) 373 | 374 | let qualified name = 375 | tident_ [Names.runtime; Names.printers; name] 376 | 377 | let rec path_to_longident p = 378 | let open Path in 379 | match p with 380 | | Pident { Ident.name; _ } -> Lident name 381 | | Pdot (t, name, _) -> Ldot (path_to_longident t, name) 382 | | Papply _ -> assert false 383 | 384 | let tident_with_path prefix name = 385 | let pd = pdot prefix name in 386 | expr_from_desc @@ Texp_ident ( 387 | pd, { 388 | txt = path_to_longident pd; 389 | loc =dummy_loc 390 | }, 391 | dummy_value_desc) 392 | 393 | let appl_desc (name:string) args = 394 | Texp_apply (tident name, args) 395 | 396 | let tapp exp args = 397 | match args with 398 | | [] -> exp 399 | | _ -> 400 | expr_from_desc @@ Texp_apply (exp, dummy_args args) 401 | 402 | let args_to_exprs args = 403 | let remove_opt a = 404 | match a with 405 | | Some b -> b 406 | | None -> failwith "expected a to have a value" 407 | in 408 | args |> List.map (fun (_, a, _) -> a) |> List.map remove_opt 409 | 410 | let show_type ty = 411 | Printtyp.reset (); 412 | Printtyp.mark_loops ty; 413 | Format.asprintf "%a" Printtyp.type_expr ty 414 | 415 | let print_type ty = 416 | ty |> show_type |> print_endline 417 | 418 | let show_expr e = 419 | Typpx.Untypeast.untype_expression e 420 | |> Pprintast.string_of_expression 421 | |> replace " +" " " 422 | 423 | let print_expr e = 424 | print_endline @@ show_expr e 425 | 426 | let show_structure e = 427 | Typpx.Untypeast.untype_structure e 428 | |> Untyped.show_structure 429 | 430 | let print_structure s = 431 | print_endline @@ show_structure s 432 | 433 | end 434 | 435 | -------------------------------------------------------------------------------- /src/PolyPrint.ml: -------------------------------------------------------------------------------- 1 | 2 | let to_string : 'a -> string = 3 | fun _ -> raise (Failure "ppx_polyprint not set up properly?") 4 | 5 | let string_of = to_string 6 | 7 | let show = to_string 8 | 9 | let print x = x |> to_string |> print_endline 10 | 11 | let debug = print 12 | 13 | type param_name = string 14 | type fn_name = string 15 | type value = string 16 | type file_path = string 17 | type line_number = int 18 | 19 | type 'a printer = 'a -> string 20 | type 'a param_spec = param_name * 'a printer * 'a 21 | type loc = file_path * line_number 22 | 23 | module type TraceConfig = sig 24 | 25 | class api : object 26 | 27 | (** High-level API, for configuring how tracing is performed. *) 28 | 29 | method sep : string 30 | method fn : fn_name -> string 31 | method arg : param_name -> value -> string 32 | method result : fn_name -> value -> string 33 | 34 | (** Low-level API, for tweaks that fundamentally change how function 35 | tracing is done. All the different arities need to be implemented 36 | for consistency. 37 | 38 | There is no conceptual difference between all these functions of 39 | different arity: a function may be of any arity, depending on how 40 | many parameters are being tracked. *) 41 | 42 | method print_result : 'a . string -> 'a printer -> 'a -> unit 43 | 44 | method call1 : 'a 'b . loc -> 45 | ('a -> 'b) -> 'a -> 'b 46 | method call2 : 'a 'b 'c . loc -> 47 | ('a -> 'b -> 'c) -> 'a -> 'b -> 'c 48 | method call3 : 'a 'b 'c 'd . loc 49 | -> ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd 50 | method call4 : 'a 'b 'c 'd 'e . loc 51 | -> ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e 52 | method call5 : 'a 'b 'c 'd 'e 'f . loc 53 | -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f 54 | method call6 : 'a 'b 'c 'd 'e 'f 'g . loc 55 | -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g 56 | method call7 : 'a 'b 'c 'd 'e 'f 'g 'h . loc 57 | -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h 58 | 59 | method print_args1 : 'a . string -> 60 | 'a param_spec -> unit 61 | method print_args2 : 'a 'b . string -> 62 | 'a param_spec -> 63 | 'b param_spec -> unit 64 | method print_args3 : 'a 'b 'c . string -> 65 | 'a param_spec -> 66 | 'b param_spec -> 67 | 'c param_spec -> unit 68 | method print_args4 : 'a 'b 'c 'd . string -> 69 | 'a param_spec -> 70 | 'b param_spec -> 71 | 'c param_spec -> 72 | 'd param_spec -> unit 73 | method print_args5 : 'a 'b 'c 'd 'e . string -> 74 | 'a param_spec -> 75 | 'b param_spec -> 76 | 'c param_spec -> 77 | 'd param_spec -> 78 | 'e param_spec -> unit 79 | method print_args6 : 'a 'b 'c 'd 'e 'f . string -> 80 | 'a param_spec -> 81 | 'b param_spec -> 82 | 'c param_spec -> 83 | 'd param_spec -> 84 | 'e param_spec -> 85 | 'f param_spec -> unit 86 | method print_args7 : 'a 'b 'c 'd 'e 'f 'g . string -> 87 | 'a param_spec -> 88 | 'b param_spec -> 89 | 'c param_spec -> 90 | 'd param_spec -> 91 | 'e param_spec -> 92 | 'f param_spec -> 93 | 'g param_spec -> unit 94 | 95 | method run1 : 'a 'b . string -> 96 | 'a param_spec -> 97 | 'b printer -> ('a -> 'b) -> 'b 98 | method run2 : 'a 'b 'c . string -> 99 | 'a param_spec -> 100 | 'b param_spec -> 101 | 'c printer -> ('a -> 'b -> 'c) -> 'c 102 | method run3 : 'a 'b 'c 'd . string -> 103 | 'a param_spec -> 104 | 'b param_spec -> 105 | 'c param_spec -> 106 | 'd printer -> ('a -> 'b -> 'c -> 'd) -> 'd 107 | method run4 : 'a 'b 'c 'd 'e . string -> 108 | 'a param_spec -> 109 | 'b param_spec -> 110 | 'c param_spec -> 111 | 'd param_spec -> 112 | 'e printer -> ('a -> 'b -> 'c -> 'd -> 'e) -> 'e 113 | method run5 : 'a 'b 'c 'd 'e 'f . string -> 114 | 'a param_spec -> 115 | 'b param_spec -> 116 | 'c param_spec -> 117 | 'd param_spec -> 118 | 'e param_spec -> 119 | 'f printer -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'f 120 | method run6 : 'a 'b 'c 'd 'e 'f 'g . string -> 121 | 'a param_spec -> 122 | 'b param_spec -> 123 | 'c param_spec -> 124 | 'd param_spec -> 125 | 'e param_spec -> 126 | 'f param_spec -> 127 | 'g printer -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'g 128 | method run7 : 'a 'b 'c 'd 'e 'f 'g 'h . string -> 129 | 'a param_spec -> 130 | 'b param_spec -> 131 | 'c param_spec -> 132 | 'd param_spec -> 133 | 'e param_spec -> 134 | 'f param_spec -> 135 | 'g param_spec -> 136 | 'h printer -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'h 137 | 138 | end 139 | 140 | val act : api 141 | end 142 | 143 | module DefaultTraceConfig : TraceConfig = struct 144 | 145 | open Printf 146 | 147 | class api = object (self) 148 | 149 | method sep = " | " 150 | method fn name = name ^ " <-" 151 | method arg name value = sprintf "%s = %s" name value 152 | method result fn_name value = sprintf "%s -> %s" fn_name value 153 | 154 | method print_result : 'a . string -> 'a printer -> 'a -> unit = 155 | fun fn_name pr_res res -> 156 | print_endline (self#result fn_name (pr_res res)) 157 | 158 | method call1 : 'a 'b . loc -> ('a -> 'b) -> 'a -> 'b = 159 | fun _ fn a -> fn a 160 | method call2 : 'a 'b 'c . loc -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = 161 | fun _ fn a b -> fn a b 162 | method call3 : 'a 'b 'c 'd . loc -> ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd = 163 | fun _ fn a b c -> fn a b c 164 | method call4 : 'a 'b 'c 'd 'e . loc -> ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = 165 | fun _ fn a b c d -> fn a b c d 166 | method call5 : 'a 'b 'c 'd 'e 'f . loc -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f = 167 | fun _ fn a b c d e -> fn a b c d e 168 | method call6 : 'a 'b 'c 'd 'e 'f 'g . loc -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g = 169 | fun _ fn a b c d e f -> fn a b c d e f 170 | method call7 : 'a 'b 'c 'd 'e 'f 'g 'h . loc -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h = 171 | fun _ fn a b c d e f g -> fn a b c d e f g 172 | 173 | method print_args1 : 'a . string -> 'a param_spec -> unit = 174 | fun fn_name (a_n, pr_a, a) -> 175 | printf "%s %s\n" (self#fn fn_name) (String.concat self#sep [(self#arg a_n (pr_a a))]) 176 | 177 | method print_args2 : 'a 'b . string -> 'a param_spec -> 'b param_spec -> unit = 178 | fun fn_name (a_n, pr_a, a) (b_n, pr_b, b) -> 179 | printf "%s %s\n" (self#fn fn_name) (String.concat self#sep [(self#arg a_n (pr_a a)); (self#arg b_n (pr_b b))]) 180 | 181 | method print_args3 : 'a 'b 'c . string -> 'a param_spec -> 'b param_spec -> 'c param_spec -> unit = 182 | fun fn_name (a_n, pr_a, a) (b_n, pr_b, b) (c_n, pr_c, c) -> 183 | printf "%s %s\n" (self#fn fn_name) (String.concat self#sep [(self#arg a_n (pr_a a)); (self#arg b_n (pr_b b)); (self#arg c_n (pr_c c))]) 184 | 185 | method print_args4 : 'a 'b 'c 'd . string -> 'a param_spec -> 'b param_spec -> 'c param_spec -> 'd param_spec -> unit = 186 | fun fn_name (a_n, pr_a, a) (b_n, pr_b, b) (c_n, pr_c, c) (d_n, pr_d, d) -> 187 | printf "%s %s\n" (self#fn fn_name) (String.concat self#sep [(self#arg a_n (pr_a a)); (self#arg b_n (pr_b b)); (self#arg c_n (pr_c c)); (self#arg d_n (pr_d d))]) 188 | 189 | method print_args5 : 'a 'b 'c 'd 'e . string -> 'a param_spec -> 'b param_spec -> 'c param_spec -> 'd param_spec -> 'e param_spec -> unit = 190 | fun fn_name (a_n, pr_a, a) (b_n, pr_b, b) (c_n, pr_c, c) (d_n, pr_d, d) (e_n, pr_e, e) -> 191 | printf "%s %s\n" (self#fn fn_name) (String.concat self#sep [(self#arg a_n (pr_a a)); (self#arg b_n (pr_b b)); (self#arg c_n (pr_c c)); (self#arg d_n (pr_d d)); (self#arg e_n (pr_e e))]) 192 | 193 | method print_args6 : 'a 'b 'c 'd 'e 'f . string -> 'a param_spec -> 'b param_spec -> 'c param_spec -> 'd param_spec -> 'e param_spec -> 'f param_spec -> unit = 194 | fun fn_name (a_n, pr_a, a) (b_n, pr_b, b) (c_n, pr_c, c) (d_n, pr_d, d) (e_n, pr_e, e) (f_n, pr_f, f) -> 195 | printf "%s %s\n" (self#fn fn_name) (String.concat self#sep [(self#arg a_n (pr_a a)); (self#arg b_n (pr_b b)); (self#arg c_n (pr_c c)); (self#arg d_n (pr_d d)); (self#arg e_n (pr_e e)); (self#arg f_n (pr_f f))]) 196 | 197 | method print_args7 : 'a 'b 'c 'd 'e 'f 'g . string -> 'a param_spec -> 'b param_spec -> 'c param_spec -> 'd param_spec -> 'e param_spec -> 'f param_spec -> 'g param_spec -> unit = 198 | fun fn_name (a_n, pr_a, a) (b_n, pr_b, b) (c_n, pr_c, c) (d_n, pr_d, d) (e_n, pr_e, e) (f_n, pr_f, f) (g_n, pr_g, g) -> 199 | printf "%s %s\n" (self#fn fn_name) (String.concat self#sep [(self#arg a_n (pr_a a)); (self#arg b_n (pr_b b)); (self#arg c_n (pr_c c)); (self#arg d_n (pr_d d)); (self#arg e_n (pr_e e)); (self#arg f_n (pr_f f)); (self#arg g_n (pr_g g))]) 200 | 201 | method run1 : 'a 'b . string -> 'a param_spec -> 'b printer -> ('a -> 'b) -> 'b = 202 | fun fn_name ((_, _, a) as aa) pr_res fn -> 203 | self#print_args1 fn_name aa; 204 | let res = fn a in 205 | self#print_result fn_name pr_res res; 206 | res 207 | 208 | method run2 : 'a 'b 'c . string -> 'a param_spec -> 'b param_spec -> 'c printer -> ('a -> 'b -> 'c) -> 'c = 209 | fun fn_name ((_, _, a) as aa) ((_, _, b) as bb) pr_res fn -> 210 | self#print_args2 fn_name aa bb; 211 | let res = fn a b in 212 | self#print_result fn_name pr_res res; 213 | res 214 | 215 | method run3 : 'a 'b 'c 'd . string -> 'a param_spec -> 'b param_spec -> 'c param_spec -> 'd printer -> ('a -> 'b -> 'c -> 'd) -> 'd = 216 | fun fn_name ((_, _, a) as aa) ((_, _, b) as bb) ((_, _, c) as cc) pr_res fn -> 217 | self#print_args3 fn_name aa bb cc; 218 | let res = fn a b c in 219 | self#print_result fn_name pr_res res; 220 | res 221 | 222 | method run4 : 'a 'b 'c 'd 'e . string -> 'a param_spec -> 'b param_spec -> 'c param_spec -> 'd param_spec -> 'e printer -> ('a -> 'b -> 'c -> 'd -> 'e) -> 'e = 223 | fun fn_name ((_, _, a) as aa) ((_, _, b) as bb) ((_, _, c) as cc) ((_, _, d) as dd) pr_res fn -> 224 | self#print_args4 fn_name aa bb cc dd; 225 | let res = fn a b c d in 226 | self#print_result fn_name pr_res res; 227 | res 228 | 229 | method run5 : 'a 'b 'c 'd 'e 'f . string -> 'a param_spec -> 'b param_spec -> 'c param_spec -> 'd param_spec -> 'e param_spec -> 'f printer -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'f = 230 | fun fn_name ((_, _, a) as aa) ((_, _, b) as bb) ((_, _, c) as cc) ((_, _, d) as dd) ((_, _, e) as ee) pr_res fn -> 231 | self#print_args5 fn_name aa bb cc dd ee; 232 | let res = fn a b c d e in 233 | self#print_result fn_name pr_res res; 234 | res 235 | 236 | method run6 : 'a 'b 'c 'd 'e 'f 'g . string -> 'a param_spec -> 'b param_spec -> 'c param_spec -> 'd param_spec -> 'e param_spec -> 'f param_spec -> 'g printer -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> 'g = 237 | fun fn_name ((_, _, a) as aa) ((_, _, b) as bb) ((_, _, c) as cc) ((_, _, d) as dd) ((_, _, e) as ee) ((_, _, f) as ff) pr_res fn -> 238 | self#print_args6 fn_name aa bb cc dd ee ff; 239 | let res = fn a b c d e f in 240 | self#print_result fn_name pr_res res; 241 | res 242 | 243 | method run7 : 'a 'b 'c 'd 'e 'f 'g 'h . string -> 'a param_spec -> 'b param_spec -> 'c param_spec -> 'd param_spec -> 'e param_spec -> 'f param_spec -> 'g param_spec -> 'h printer -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'h = 244 | fun fn_name ((_, _, a) as aa) ((_, _, b) as bb) ((_, _, c) as cc) ((_, _, d) as dd) ((_, _, e) as ee) ((_, _, f) as ff) ((_, _, g) as gg) pr_res fn -> 245 | self#print_args7 fn_name aa bb cc dd ee ff gg; 246 | let res = fn a b c d e f g in 247 | self#print_result fn_name pr_res res; 248 | res 249 | end 250 | 251 | let act = new api 252 | end 253 | 254 | module Printers = struct 255 | 256 | let string_of_int = string_of_int 257 | let string_of_int32 = Int32.to_string 258 | let string_of_int64 = Int64.to_string 259 | let string_of_nativeint = Nativeint.to_string 260 | 261 | let string_of_bool = string_of_bool 262 | let string_of_float = string_of_float 263 | 264 | let string_of_char = String.make 1 265 | let string_of_exn = Printexc.to_string 266 | 267 | open Format 268 | 269 | let pp_tvar name fmt _ = 270 | match name with 271 | | "" -> fprintf fmt "" 272 | | v -> fprintf fmt "'_%s" v 273 | 274 | let pp_option pp fmt x = 275 | match x with 276 | | Some s -> fprintf fmt "Some %a" pp s 277 | | None -> fprintf fmt "None" 278 | 279 | let pp_ref pp fmt x = 280 | fprintf fmt "ref %a" pp !x 281 | 282 | let pp_unit fmt x = 283 | fprintf fmt "()" 284 | 285 | let pp_exc fmt x = 286 | fprintf fmt "%s" (Printexc.to_string x) 287 | 288 | let pp_int32 fmt x = 289 | fprintf fmt "%ld" x 290 | 291 | let pp_int64 fmt x = 292 | fprintf fmt "%Ld" x 293 | 294 | let pp_nativeint fmt x = 295 | fprintf fmt "%nd" x 296 | 297 | let rec pp_list pp fmt xs = 298 | let rec aux xs = 299 | match xs with 300 | | [] -> fprintf fmt "" 301 | | [x] -> fprintf fmt "%a" pp x 302 | | y :: ys -> fprintf fmt "%a; " pp y; aux ys 303 | in 304 | fprintf fmt "["; 305 | aux xs; 306 | fprintf fmt "]" 307 | 308 | let pp_function fmt _ = fprintf fmt "" 309 | 310 | let pp_function_rep f fmt _ = fprintf fmt "" f 311 | 312 | let pp_misc s fmt _ = fprintf fmt "%s" s 313 | 314 | let pp_tuple pr_a pr_b fmt (a, b) = 315 | fprintf fmt "(%a, %a)" pr_a a pr_b b 316 | let pp_tuple3 pr_a pr_b pr_c fmt (a, b, c) = 317 | fprintf fmt "(%a, %a, %a)" pr_a a pr_b b pr_c c 318 | let pp_tuple4 pr_a pr_b pr_c pr_d fmt (a, b, c, d) = 319 | fprintf fmt "(%a, %a, %a, %a)" pr_a a pr_b b pr_c c pr_d d 320 | let pp_tuple5 pr_a pr_b pr_c pr_d pr_e fmt (a, b, c, d, e) = 321 | fprintf fmt "(%a, %a, %a, %a, %a)" pr_a a pr_b b pr_c c pr_d d pr_e e 322 | let pp_tuple6 pr_a pr_b pr_c pr_d pr_e pr_f fmt (a, b, c, d, e, f) = 323 | fprintf fmt "(%a, %a, %a, %a, %a, %a)" pr_a a pr_b b pr_c c pr_d d pr_e e pr_f f 324 | let pp_tuple7 pr_a pr_b pr_c pr_d pr_e pr_f pr_g fmt (a, b, c, d, e, f, g) = 325 | fprintf fmt "(%a, %a, %a, %a, %a, %a, %a)" pr_a a pr_b b pr_c c pr_d d pr_e e pr_f f pr_g g 326 | end 327 | 328 | type ('a, 'b) traced1 = Traced1 of ('a -> 'b) 329 | type ('a, 'b, 'c) traced2 = Traced2 of ('a -> 'b -> 'c) 330 | type ('a, 'b, 'c, 'd) traced3 = Traced3 of ('a -> 'b -> 'c -> 'd) 331 | type ('a, 'b, 'c, 'd, 'e) traced4 = Traced4 of ('a -> 'b -> 'c -> 'd -> 'e) 332 | type ('a, 'b, 'c, 'd, 'e, 'f) traced5 = Traced5 of ('a -> 'b -> 'c -> 'd -> 'e -> 'f) 333 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g) traced6 = Traced6 of ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) 334 | type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) traced7 = Traced7 of ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) 335 | 336 | let wrap1 loc (module TC : TraceConfig) (Traced1 fn) a = TC.act#call1 loc fn a 337 | let wrap2 loc (module TC : TraceConfig) (Traced2 fn) a b = TC.act#call2 loc fn a b 338 | let wrap3 loc (module TC : TraceConfig) (Traced3 fn) a b c = TC.act#call3 loc fn a b c 339 | let wrap4 loc (module TC : TraceConfig) (Traced4 fn) a b c d = TC.act#call4 loc fn a b c d 340 | let wrap5 loc (module TC : TraceConfig) (Traced5 fn) a b c d e = TC.act#call5 loc fn a b c d e 341 | let wrap6 loc (module TC : TraceConfig) (Traced6 fn) a b c d e f = TC.act#call6 loc fn a b c d e f 342 | let wrap7 loc (module TC : TraceConfig) (Traced7 fn) a b c d e f g = TC.act#call7 loc fn a b c d e f g 343 | -------------------------------------------------------------------------------- /src/PolyPrint.mllib: -------------------------------------------------------------------------------- 1 | PolyPrint -------------------------------------------------------------------------------- /src/_tags: -------------------------------------------------------------------------------- 1 | true: package(compiler-libs.common typpx ppx_tools.metaquot str) -------------------------------------------------------------------------------- /src/ppx_polyprint.ml: -------------------------------------------------------------------------------- 1 | 2 | open Ast_mapper 3 | open Ast_helper 4 | open Asttypes 5 | open Longident 6 | 7 | let pre_mapper = 8 | { default_mapper with 9 | expr = begin 10 | fun mapper expr -> 11 | expr 12 | |> PPTrace.annotation_mapper.expr 13 | PPTrace.annotation_mapper 14 | (* |> (fun e -> print_endline @@ Pprintast.string_of_expression e; e) *) 15 | |> PPShow.eta_abstraction_mapper.expr 16 | PPShow.eta_abstraction_mapper 17 | (* |> (fun e -> print_endline @@ Pprintast.string_of_expression e; e) *) 18 | end; 19 | structure_item = 20 | fun mapper expr -> 21 | expr 22 | |> PPTrace.annotation_mapper.structure_item 23 | PPTrace.annotation_mapper 24 | (* |> (fun e -> print_endline @@ Pprintast.string_of_structure [e]; e) *) 25 | |> PPShow.eta_abstraction_mapper.structure_item 26 | PPShow.eta_abstraction_mapper 27 | (* |> (fun e -> print_endline @@ Pprintast.string_of_structure [e]; e) *) 28 | } 29 | 30 | module Main = PPDriver.Make.F(struct 31 | let tool_name = "ppx_polyprint" 32 | let args = [] 33 | let firstUntypedTransformation = pre_mapper 34 | module Typemod = PPTypemod 35 | module TypedTransformation = TypedtreeMap.MakeMap(PPShow.TypedTransform) 36 | let lastUntypedTransformation = Typpx.Default.untyped_identity 37 | end) 38 | 39 | let () = 40 | PPEnv.init (); 41 | Main.run (); 42 | -------------------------------------------------------------------------------- /src/typing/PPTypeclass.ml: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | module Typecore = PPTypecore 14 | 15 | open Parsetree 16 | open Asttypes 17 | open Path 18 | open Types 19 | open Typecore 20 | open Typetexp 21 | open Format 22 | 23 | type error = 24 | Unconsistent_constraint of (type_expr * type_expr) list 25 | | Field_type_mismatch of string * string * (type_expr * type_expr) list 26 | | Structure_expected of class_type 27 | | Cannot_apply of class_type 28 | | Apply_wrong_label of label 29 | | Pattern_type_clash of type_expr 30 | | Repeated_parameter 31 | | Unbound_class_2 of Longident.t 32 | | Unbound_class_type_2 of Longident.t 33 | | Abbrev_type_clash of type_expr * type_expr * type_expr 34 | | Constructor_type_mismatch of string * (type_expr * type_expr) list 35 | | Virtual_class of bool * bool * string list * string list 36 | | Parameter_arity_mismatch of Longident.t * int * int 37 | | Parameter_mismatch of (type_expr * type_expr) list 38 | | Bad_parameters of Ident.t * type_expr * type_expr 39 | | Class_match_failure of Ctype.class_match_failure list 40 | | Unbound_val of string 41 | | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure 42 | | Make_nongen_seltype of type_expr 43 | | Non_generalizable_class of Ident.t * Types.class_declaration 44 | | Cannot_coerce_self of type_expr 45 | | Non_collapsable_conjunction of 46 | Ident.t * Types.class_declaration * (type_expr * type_expr) list 47 | | Final_self_clash of (type_expr * type_expr) list 48 | | Mutability_mismatch of string * mutable_flag 49 | | No_overriding of string * string 50 | | Duplicate of string * string 51 | 52 | exception Error of Location.t * Env.t * error 53 | exception Error_forward of Location.error 54 | 55 | open Typedtree 56 | 57 | let ctyp desc typ env loc = 58 | { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env; ctyp_attributes = [] } 59 | 60 | (**********************) 61 | (* Useful constants *) 62 | (**********************) 63 | 64 | 65 | (* 66 | Self type have a dummy private method, thus preventing it to become 67 | closed. 68 | *) 69 | let dummy_method = Btype.dummy_method 70 | 71 | (* 72 | Path associated to the temporary class type of a class being typed 73 | (its constructor is not available). 74 | *) 75 | let unbound_class = Path.Pident (Ident.create "") 76 | 77 | 78 | (************************************) 79 | (* Some operations on class types *) 80 | (************************************) 81 | 82 | 83 | (* Fully expand the head of a class type *) 84 | let rec scrape_class_type = 85 | function 86 | Cty_constr (_, _, cty) -> scrape_class_type cty 87 | | cty -> cty 88 | 89 | (* Generalize a class type *) 90 | let rec generalize_class_type gen = 91 | function 92 | Cty_constr (_, params, cty) -> 93 | List.iter gen params; 94 | generalize_class_type gen cty 95 | | Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} -> 96 | gen sty; 97 | Vars.iter (fun _ (_, _, ty) -> gen ty) vars; 98 | List.iter (fun (_,tl) -> List.iter gen tl) inher 99 | | Cty_arrow (_, ty, cty) -> 100 | gen ty; 101 | generalize_class_type gen cty 102 | 103 | let generalize_class_type vars = 104 | let gen = if vars then Ctype.generalize else Ctype.generalize_structure in 105 | generalize_class_type gen 106 | 107 | (* Return the virtual methods of a class type *) 108 | let virtual_methods sign = 109 | let (fields, _) = 110 | Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self) 111 | in 112 | List.fold_left 113 | (fun virt (lab, _, _) -> 114 | if lab = dummy_method then virt else 115 | if Concr.mem lab sign.csig_concr then virt else 116 | lab::virt) 117 | [] fields 118 | 119 | (* Return the constructor type associated to a class type *) 120 | let rec constructor_type constr cty = 121 | match cty with 122 | Cty_constr (_, _, cty) -> 123 | constructor_type constr cty 124 | | Cty_signature sign -> 125 | constr 126 | | Cty_arrow (l, ty, cty) -> 127 | Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok)) 128 | 129 | let rec class_body cty = 130 | match cty with 131 | Cty_constr (_, _, cty') -> 132 | cty (* Only class bodies can be abbreviated *) 133 | | Cty_signature sign -> 134 | cty 135 | | Cty_arrow (_, ty, cty) -> 136 | class_body cty 137 | 138 | let extract_constraints cty = 139 | let sign = Ctype.signature_of_class_type cty in 140 | (Vars.fold (fun lab _ vars -> lab :: vars) sign.csig_vars [], 141 | begin let (fields, _) = 142 | Ctype.flatten_fields (Ctype.object_fields sign.csig_self) 143 | in 144 | List.fold_left 145 | (fun meths (lab, _, _) -> 146 | if lab = dummy_method then meths else lab::meths) 147 | [] fields 148 | end, 149 | sign.csig_concr) 150 | 151 | let rec abbreviate_class_type path params cty = 152 | match cty with 153 | Cty_constr (_, _, _) | Cty_signature _ -> 154 | Cty_constr (path, params, cty) 155 | | Cty_arrow (l, ty, cty) -> 156 | Cty_arrow (l, ty, abbreviate_class_type path params cty) 157 | 158 | let rec closed_class_type = 159 | function 160 | Cty_constr (_, params, _) -> 161 | List.for_all Ctype.closed_schema params 162 | | Cty_signature sign -> 163 | Ctype.closed_schema sign.csig_self 164 | && 165 | Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc) 166 | sign.csig_vars 167 | true 168 | | Cty_arrow (_, ty, cty) -> 169 | Ctype.closed_schema ty 170 | && 171 | closed_class_type cty 172 | 173 | let closed_class cty = 174 | List.for_all Ctype.closed_schema cty.cty_params 175 | && 176 | closed_class_type cty.cty_type 177 | 178 | let rec limited_generalize rv = 179 | function 180 | Cty_constr (path, params, cty) -> 181 | List.iter (Ctype.limited_generalize rv) params; 182 | limited_generalize rv cty 183 | | Cty_signature sign -> 184 | Ctype.limited_generalize rv sign.csig_self; 185 | Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty) 186 | sign.csig_vars; 187 | List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl) 188 | sign.csig_inher 189 | | Cty_arrow (_, ty, cty) -> 190 | Ctype.limited_generalize rv ty; 191 | limited_generalize rv cty 192 | 193 | (* Record a class type *) 194 | let rc node = 195 | Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node); 196 | Stypes.record (Stypes.Ti_class node); (* moved to genannot *) 197 | node 198 | 199 | 200 | (***********************************) 201 | (* Primitives for typing classes *) 202 | (***********************************) 203 | 204 | 205 | (* Enter a value in the method environment only *) 206 | let enter_met_env ?check loc lab kind ty val_env met_env par_env = 207 | let (id, val_env) = 208 | Env.enter_value lab {val_type = ty; val_kind = Val_unbound; 209 | val_attributes = []; 210 | Types.val_loc = loc} val_env 211 | in 212 | (id, val_env, 213 | Env.add_value ?check id {val_type = ty; val_kind = kind; 214 | val_attributes = []; 215 | Types.val_loc = loc} met_env, 216 | Env.add_value id {val_type = ty; val_kind = Val_unbound; 217 | val_attributes = []; 218 | Types.val_loc = loc} par_env) 219 | 220 | (* Enter an instance variable in the environment *) 221 | let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc = 222 | let instance = Ctype.instance val_env in 223 | let (id, virt) = 224 | try 225 | let (id, mut', virt', ty') = Vars.find lab !vars in 226 | if mut' <> mut then 227 | raise (Error(loc, val_env, Mutability_mismatch(lab, mut))); 228 | Ctype.unify val_env (instance ty) (instance ty'); 229 | (if not inh then Some id else None), 230 | (if virt' = Concrete then virt' else virt) 231 | with 232 | Ctype.Unify tr -> 233 | raise (Error(loc, val_env, 234 | Field_type_mismatch("instance variable", lab, tr))) 235 | | Not_found -> None, virt 236 | in 237 | let (id, _, _, _) as result = 238 | match id with Some id -> (id, val_env, met_env, par_env) 239 | | None -> 240 | enter_met_env Location.none lab (Val_ivar (mut, cl_num)) 241 | ty val_env met_env par_env 242 | in 243 | vars := Vars.add lab (id, mut, virt, ty) !vars; 244 | result 245 | 246 | let concr_vals vars = 247 | Vars.fold 248 | (fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s) 249 | vars Concr.empty 250 | 251 | let inheritance self_type env ovf concr_meths warn_vals loc parent = 252 | match scrape_class_type parent with 253 | Cty_signature cl_sig -> 254 | 255 | (* Methods *) 256 | begin try 257 | Ctype.unify env self_type cl_sig.csig_self 258 | with Ctype.Unify trace -> 259 | match trace with 260 | _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem -> 261 | raise(Error(loc, env, Field_type_mismatch ("method", n, rem))) 262 | | _ -> 263 | assert false 264 | end; 265 | 266 | (* Overriding *) 267 | let over_meths = Concr.inter cl_sig.csig_concr concr_meths in 268 | let concr_vals = concr_vals cl_sig.csig_vars in 269 | let over_vals = Concr.inter concr_vals warn_vals in 270 | begin match ovf with 271 | Some Fresh -> 272 | let cname = 273 | match parent with 274 | Cty_constr (p, _, _) -> Path.name p 275 | | _ -> "inherited" 276 | in 277 | if not (Concr.is_empty over_meths) then 278 | Location.prerr_warning loc 279 | (Warnings.Method_override (cname :: Concr.elements over_meths)); 280 | if not (Concr.is_empty over_vals) then 281 | Location.prerr_warning loc 282 | (Warnings.Instance_variable_override 283 | (cname :: Concr.elements over_vals)); 284 | | Some Override 285 | when Concr.is_empty over_meths && Concr.is_empty over_vals -> 286 | raise (Error(loc, env, No_overriding ("",""))) 287 | | _ -> () 288 | end; 289 | 290 | let concr_meths = Concr.union cl_sig.csig_concr concr_meths 291 | and warn_vals = Concr.union concr_vals warn_vals in 292 | 293 | (cl_sig, concr_meths, warn_vals) 294 | 295 | | _ -> 296 | raise(Error(loc, env, Structure_expected parent)) 297 | 298 | let virtual_method val_env meths self_type lab priv sty loc = 299 | let (_, ty') = 300 | Ctype.filter_self_method val_env lab priv meths self_type 301 | in 302 | let sty = Ast_helper.Typ.force_poly sty in 303 | let cty = transl_simple_type val_env false sty in 304 | let ty = cty.ctyp_type in 305 | begin 306 | try Ctype.unify val_env ty ty' with Ctype.Unify trace -> 307 | raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace))); 308 | end; 309 | cty 310 | 311 | let delayed_meth_specs = ref [] 312 | 313 | let declare_method val_env meths self_type lab priv sty loc = 314 | let (_, ty') = 315 | Ctype.filter_self_method val_env lab priv meths self_type 316 | in 317 | let unif ty = 318 | try Ctype.unify val_env ty ty' with Ctype.Unify trace -> 319 | raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace))) 320 | in 321 | let sty = Ast_helper.Typ.force_poly sty in 322 | match sty.ptyp_desc, priv with 323 | Ptyp_poly ([],sty'), Public -> 324 | (* TODO: we moved the [transl_simple_type_univars] outside of the lazy, 325 | so that we can get an immediate value. Is that correct ? Ask Jacques. *) 326 | let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in 327 | delayed_meth_specs := 328 | lazy ( 329 | let cty = transl_simple_type_univars val_env sty' in 330 | let ty = cty.ctyp_type in 331 | unif ty; 332 | returned_cty.ctyp_desc <- Ttyp_poly ([], cty); 333 | returned_cty.ctyp_type <- ty; 334 | ) :: 335 | !delayed_meth_specs; 336 | returned_cty 337 | | _ -> 338 | let cty = transl_simple_type val_env false sty in 339 | let ty = cty.ctyp_type in 340 | unif ty; 341 | cty 342 | 343 | let type_constraint val_env sty sty' loc = 344 | let cty = transl_simple_type val_env false sty in 345 | let ty = cty.ctyp_type in 346 | let cty' = transl_simple_type val_env false sty' in 347 | let ty' = cty'.ctyp_type in 348 | begin 349 | try Ctype.unify val_env ty ty' with Ctype.Unify trace -> 350 | raise(Error(loc, val_env, Unconsistent_constraint trace)); 351 | end; 352 | (cty, cty') 353 | 354 | let make_method loc cl_num expr = 355 | let open Ast_helper in 356 | let mkid s = mkloc s loc in 357 | Exp.fun_ ~loc:expr.pexp_loc "" None 358 | (Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num))) 359 | expr 360 | 361 | (*******************************) 362 | 363 | let add_val env loc lab (mut, virt, ty) val_sig = 364 | let virt = 365 | try 366 | let (mut', virt', ty') = Vars.find lab val_sig in 367 | if virt' = Concrete then virt' else virt 368 | with Not_found -> virt 369 | in 370 | Vars.add lab (mut, virt, ty) val_sig 371 | 372 | let rec class_type_field env self_type meths 373 | (fields, val_sig, concr_meths, inher) ctf = 374 | let loc = ctf.pctf_loc in 375 | let mkctf desc = { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes } in 376 | match ctf.pctf_desc with 377 | Pctf_inherit sparent -> 378 | let parent = class_type env sparent in 379 | let inher = 380 | match parent.cltyp_type with 381 | Cty_constr (p, tl, _) -> (p, tl) :: inher 382 | | _ -> inher 383 | in 384 | let (cl_sig, concr_meths, _) = 385 | inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc 386 | parent.cltyp_type 387 | in 388 | let val_sig = 389 | Vars.fold (add_val env sparent.pcty_loc) cl_sig.csig_vars val_sig in 390 | (mkctf (Tctf_inherit parent) :: fields, 391 | val_sig, concr_meths, inher) 392 | 393 | | Pctf_val (lab, mut, virt, sty) -> 394 | let cty = transl_simple_type env false sty in 395 | let ty = cty.ctyp_type in 396 | (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields, 397 | add_val env ctf.pctf_loc lab (mut, virt, ty) val_sig, concr_meths, inher) 398 | 399 | | Pctf_method (lab, priv, virt, sty) -> 400 | let cty = 401 | declare_method env meths self_type lab priv sty ctf.pctf_loc in 402 | let concr_meths = 403 | match virt with 404 | | Concrete -> Concr.add lab concr_meths 405 | | Virtual -> concr_meths 406 | in 407 | (mkctf (Tctf_method (lab, priv, virt, cty)) :: fields, 408 | val_sig, concr_meths, inher) 409 | 410 | | Pctf_constraint (sty, sty') -> 411 | let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in 412 | (mkctf (Tctf_constraint (cty, cty')) :: fields, 413 | val_sig, concr_meths, inher) 414 | 415 | | Pctf_attribute x -> 416 | Typetexp.warning_attribute [x]; 417 | (mkctf (Tctf_attribute x) :: fields, 418 | val_sig, concr_meths, inher) 419 | 420 | | Pctf_extension ext -> 421 | raise (Error_forward (Typetexp.error_of_extension ext)) 422 | 423 | and class_signature env {pcsig_self=sty; pcsig_fields=sign} = 424 | let meths = ref Meths.empty in 425 | let self_cty = transl_simple_type env false sty in 426 | let self_cty = { self_cty with 427 | ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in 428 | let self_type = self_cty.ctyp_type in 429 | 430 | (* Check that the binder is a correct type, and introduce a dummy 431 | method preventing self type from being closed. *) 432 | let dummy_obj = Ctype.newvar () in 433 | Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj) 434 | (Ctype.newty (Ttuple [])); 435 | begin try 436 | Ctype.unify env self_type dummy_obj 437 | with Ctype.Unify _ -> 438 | raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type)) 439 | end; 440 | 441 | (* Class type fields *) 442 | Typetexp.warning_enter_scope (); 443 | let (rev_fields, val_sig, concr_meths, inher) = 444 | List.fold_left (class_type_field env self_type meths) 445 | ([], Vars.empty, Concr.empty, []) 446 | sign 447 | in 448 | Typetexp.warning_leave_scope (); 449 | let cty = {csig_self = self_type; 450 | csig_vars = val_sig; 451 | csig_concr = concr_meths; 452 | csig_inher = inher} 453 | in 454 | { csig_self = self_cty; 455 | csig_fields = List.rev rev_fields; 456 | csig_type = cty; 457 | } 458 | 459 | and class_type env scty = 460 | let cltyp desc typ = 461 | { 462 | cltyp_desc = desc; 463 | cltyp_type = typ; 464 | cltyp_loc = scty.pcty_loc; 465 | cltyp_env = env; 466 | cltyp_attributes = scty.pcty_attributes; 467 | } 468 | in 469 | match scty.pcty_desc with 470 | Pcty_constr (lid, styl) -> 471 | let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in 472 | if Path.same decl.clty_path unbound_class then 473 | raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt)); 474 | let (params, clty) = 475 | Ctype.instance_class decl.clty_params decl.clty_type 476 | in 477 | if List.length params <> List.length styl then 478 | raise(Error(scty.pcty_loc, env, 479 | Parameter_arity_mismatch (lid.txt, List.length params, 480 | List.length styl))); 481 | let ctys = List.map2 482 | (fun sty ty -> 483 | let cty' = transl_simple_type env false sty in 484 | let ty' = cty'.ctyp_type in 485 | begin 486 | try Ctype.unify env ty' ty with Ctype.Unify trace -> 487 | raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace)) 488 | end; 489 | cty' 490 | ) styl params 491 | in 492 | let typ = Cty_constr (path, params, clty) in 493 | cltyp (Tcty_constr ( path, lid , ctys)) typ 494 | 495 | | Pcty_signature pcsig -> 496 | let clsig = class_signature env pcsig in 497 | let typ = Cty_signature clsig.csig_type in 498 | cltyp (Tcty_signature clsig) typ 499 | 500 | | Pcty_arrow (l, sty, scty) -> 501 | let cty = transl_simple_type env false sty in 502 | let ty = cty.ctyp_type in 503 | let clty = class_type env scty in 504 | let typ = Cty_arrow (l, ty, clty.cltyp_type) in 505 | cltyp (Tcty_arrow (l, cty, clty)) typ 506 | | Pcty_extension ext -> 507 | raise (Error_forward (Typetexp.error_of_extension ext)) 508 | 509 | let class_type env scty = 510 | delayed_meth_specs := []; 511 | let cty = class_type env scty in 512 | List.iter Lazy.force (List.rev !delayed_meth_specs); 513 | delayed_meth_specs := []; 514 | cty 515 | 516 | (*******************************) 517 | 518 | let rec class_field self_loc cl_num self_type meths vars 519 | (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher, 520 | local_meths, local_vals) 521 | cf = 522 | let loc = cf.pcf_loc in 523 | let mkcf desc = { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes } in 524 | match cf.pcf_desc with 525 | Pcf_inherit (ovf, sparent, super) -> 526 | let parent = class_expr cl_num val_env par_env sparent in 527 | let inher = 528 | match parent.cl_type with 529 | Cty_constr (p, tl, _) -> (p, tl) :: inher 530 | | _ -> inher 531 | in 532 | let (cl_sig, concr_meths, warn_vals) = 533 | inheritance self_type val_env (Some ovf) concr_meths warn_vals 534 | sparent.pcl_loc parent.cl_type 535 | in 536 | (* Variables *) 537 | let (val_env, met_env, par_env, inh_vars) = 538 | Vars.fold 539 | (fun lab info (val_env, met_env, par_env, inh_vars) -> 540 | let mut, vr, ty = info in 541 | let (id, val_env, met_env, par_env) = 542 | enter_val cl_num vars true lab mut vr ty val_env met_env par_env 543 | sparent.pcl_loc 544 | in 545 | (val_env, met_env, par_env, (lab, id) :: inh_vars)) 546 | cl_sig.csig_vars (val_env, met_env, par_env, []) 547 | in 548 | (* Inherited concrete methods *) 549 | let inh_meths = 550 | Concr.fold (fun lab rem -> (lab, Ident.create lab)::rem) 551 | cl_sig.csig_concr [] 552 | in 553 | (* Super *) 554 | let (val_env, met_env, par_env) = 555 | match super with 556 | None -> 557 | (val_env, met_env, par_env) 558 | | Some name -> 559 | let (id, val_env, met_env, par_env) = 560 | enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s) 561 | sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type 562 | val_env met_env par_env 563 | in 564 | (val_env, met_env, par_env) 565 | in 566 | (val_env, met_env, par_env, 567 | lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths))) 568 | :: fields, 569 | concr_meths, warn_vals, inher, local_meths, local_vals) 570 | 571 | | Pcf_val (lab, mut, Cfk_virtual styp) -> 572 | if !Clflags.principal then Ctype.begin_def (); 573 | let cty = Typetexp.transl_simple_type val_env false styp in 574 | let ty = cty.ctyp_type in 575 | if !Clflags.principal then begin 576 | Ctype.end_def (); 577 | Ctype.generalize_structure ty 578 | end; 579 | let (id, val_env, met_env', par_env) = 580 | enter_val cl_num vars false lab.txt mut Virtual ty 581 | val_env met_env par_env loc 582 | in 583 | (val_env, met_env', par_env, 584 | lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty, 585 | met_env == met_env'))) 586 | :: fields, 587 | concr_meths, warn_vals, inher, local_meths, local_vals) 588 | 589 | | Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) -> 590 | if Concr.mem lab.txt local_vals then 591 | raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt))); 592 | if Concr.mem lab.txt warn_vals then begin 593 | if ovf = Fresh then 594 | Location.prerr_warning lab.loc 595 | (Warnings.Instance_variable_override[lab.txt]) 596 | end else begin 597 | if ovf = Override then 598 | raise(Error(loc, val_env, 599 | No_overriding ("instance variable", lab.txt))) 600 | end; 601 | if !Clflags.principal then Ctype.begin_def (); 602 | let exp = 603 | try type_exp val_env sexp with Ctype.Unify [(ty, _)] -> 604 | raise(Error(loc, val_env, Make_nongen_seltype ty)) 605 | in 606 | if !Clflags.principal then begin 607 | Ctype.end_def (); 608 | Ctype.generalize_structure exp.exp_type 609 | end; 610 | let (id, val_env, met_env', par_env) = 611 | enter_val cl_num vars false lab.txt mut Concrete exp.exp_type 612 | val_env met_env par_env loc 613 | in 614 | (val_env, met_env', par_env, 615 | lazy (mkcf (Tcf_val (lab, mut, id, 616 | Tcfk_concrete (ovf, exp), met_env == met_env'))) 617 | :: fields, 618 | concr_meths, Concr.add lab.txt warn_vals, inher, local_meths, 619 | Concr.add lab.txt local_vals) 620 | 621 | | Pcf_method (lab, priv, Cfk_virtual sty) -> 622 | let cty = virtual_method val_env meths self_type lab.txt priv sty loc in 623 | (val_env, met_env, par_env, 624 | lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty))) 625 | ::fields, 626 | concr_meths, warn_vals, inher, local_meths, local_vals) 627 | 628 | | Pcf_method (lab, priv, Cfk_concrete (ovf, expr)) -> 629 | let expr = 630 | match expr.pexp_desc with 631 | | Pexp_poly _ -> expr 632 | | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None 633 | in 634 | if Concr.mem lab.txt local_meths then 635 | raise(Error(loc, val_env, Duplicate ("method", lab.txt))); 636 | if Concr.mem lab.txt concr_meths then begin 637 | if ovf = Fresh then 638 | Location.prerr_warning loc (Warnings.Method_override [lab.txt]) 639 | end else begin 640 | if ovf = Override then 641 | raise(Error(loc, val_env, No_overriding("method", lab.txt))) 642 | end; 643 | let (_, ty) = 644 | Ctype.filter_self_method val_env lab.txt priv meths self_type 645 | in 646 | begin try match expr.pexp_desc with 647 | Pexp_poly (sbody, sty) -> 648 | begin match sty with None -> () 649 | | Some sty -> 650 | let sty = Ast_helper.Typ.force_poly sty in 651 | let cty' = Typetexp.transl_simple_type val_env false sty in 652 | let ty' = cty'.ctyp_type in 653 | Ctype.unify val_env ty' ty 654 | end; 655 | begin match (Ctype.repr ty).desc with 656 | Tvar _ -> 657 | let ty' = Ctype.newvar () in 658 | Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty; 659 | Ctype.unify val_env (type_approx val_env sbody) ty' 660 | | Tpoly (ty1, tl) -> 661 | let _, ty1' = Ctype.instance_poly false tl ty1 in 662 | let ty2 = type_approx val_env sbody in 663 | Ctype.unify val_env ty2 ty1' 664 | | _ -> assert false 665 | end 666 | | _ -> assert false 667 | with Ctype.Unify trace -> 668 | raise(Error(loc, val_env, 669 | Field_type_mismatch ("method", lab.txt, trace))) 670 | end; 671 | let meth_expr = make_method self_loc cl_num expr in 672 | (* backup variables for Pexp_override *) 673 | let vars_local = !vars in 674 | 675 | let field = 676 | lazy begin 677 | let meth_type = 678 | Btype.newgenty (Tarrow("", self_type, ty, Cok)) in 679 | Ctype.raise_nongen_level (); 680 | vars := vars_local; 681 | let texp = type_expect met_env meth_expr meth_type in 682 | Ctype.end_def (); 683 | mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp))) 684 | end in 685 | (val_env, met_env, par_env, field::fields, 686 | Concr.add lab.txt concr_meths, warn_vals, inher, 687 | Concr.add lab.txt local_meths, local_vals) 688 | 689 | | Pcf_constraint (sty, sty') -> 690 | let (cty, cty') = type_constraint val_env sty sty' loc in 691 | (val_env, met_env, par_env, 692 | lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields, 693 | concr_meths, warn_vals, inher, local_meths, local_vals) 694 | 695 | | Pcf_initializer expr -> 696 | let expr = make_method self_loc cl_num expr in 697 | let vars_local = !vars in 698 | let field = 699 | lazy begin 700 | Ctype.raise_nongen_level (); 701 | let meth_type = 702 | Ctype.newty 703 | (Tarrow ("", self_type, 704 | Ctype.instance_def Predef.type_unit, Cok)) in 705 | vars := vars_local; 706 | let texp = type_expect met_env expr meth_type in 707 | Ctype.end_def (); 708 | mkcf (Tcf_initializer texp) 709 | end in 710 | (val_env, met_env, par_env, field::fields, concr_meths, warn_vals, 711 | inher, local_meths, local_vals) 712 | | Pcf_attribute x -> 713 | Typetexp.warning_attribute [x]; 714 | (val_env, met_env, par_env, 715 | lazy (mkcf (Tcf_attribute x)) :: fields, 716 | concr_meths, warn_vals, inher, local_meths, local_vals) 717 | | Pcf_extension ext -> 718 | raise (Error_forward (Typetexp.error_of_extension ext)) 719 | 720 | and class_structure cl_num final val_env met_env loc 721 | { pcstr_self = spat; pcstr_fields = str } = 722 | (* Environment for substructures *) 723 | let par_env = met_env in 724 | 725 | (* Location of self. Used for locations of self arguments *) 726 | let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in 727 | 728 | (* Self type, with a dummy method preventing it from being closed/escaped. *) 729 | let self_type = Ctype.newvar () in 730 | Ctype.unify val_env 731 | (Ctype.filter_method val_env dummy_method Private self_type) 732 | (Ctype.newty (Ttuple [])); 733 | 734 | (* Private self is used for private method calls *) 735 | let private_self = if final then Ctype.newvar () else self_type in 736 | 737 | (* Self binder *) 738 | let (pat, meths, vars, val_env, meth_env, par_env) = 739 | type_self_pattern cl_num private_self val_env met_env par_env spat 740 | in 741 | let public_self = pat.pat_type in 742 | 743 | (* Check that the binder has a correct type *) 744 | let ty = 745 | if final then Ctype.newty (Tobject (Ctype.newvar(), ref None)) 746 | else self_type in 747 | begin try Ctype.unify val_env public_self ty with 748 | Ctype.Unify _ -> 749 | raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self)) 750 | end; 751 | let get_methods ty = 752 | (fst (Ctype.flatten_fields 753 | (Ctype.object_fields (Ctype.expand_head val_env ty)))) in 754 | if final then begin 755 | (* Copy known information to still empty self_type *) 756 | List.iter 757 | (fun (lab,kind,ty) -> 758 | let k = 759 | if Btype.field_kind_repr kind = Fpresent then Public else Private in 760 | try Ctype.unify val_env ty 761 | (Ctype.filter_method val_env lab k self_type) 762 | with _ -> assert false) 763 | (get_methods public_self) 764 | end; 765 | 766 | (* Typing of class fields *) 767 | Typetexp.warning_enter_scope (); 768 | let (_, _, _, fields, concr_meths, _, inher, _local_meths, _local_vals) = 769 | List.fold_left (class_field self_loc cl_num self_type meths vars) 770 | (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, [], 771 | Concr.empty, Concr.empty) 772 | str 773 | in 774 | Typetexp.warning_leave_scope (); 775 | Ctype.unify val_env self_type (Ctype.newvar ()); 776 | let sign = 777 | {csig_self = public_self; 778 | csig_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars; 779 | csig_concr = concr_meths; 780 | csig_inher = inher} in 781 | let methods = get_methods self_type in 782 | let priv_meths = 783 | List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent) 784 | methods in 785 | if final then begin 786 | (* Unify private_self and a copy of self_type. self_type will not 787 | be modified after this point *) 788 | Ctype.close_object self_type; 789 | let mets = virtual_methods {sign with csig_self = self_type} in 790 | let vals = 791 | Vars.fold 792 | (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) 793 | sign.csig_vars [] in 794 | if mets <> [] || vals <> [] then 795 | raise(Error(loc, val_env, Virtual_class(true, final, mets, vals))); 796 | let self_methods = 797 | List.fold_right 798 | (fun (lab,kind,ty) rem -> 799 | if lab = dummy_method then 800 | (* allow public self and private self to be unified *) 801 | match Btype.field_kind_repr kind with 802 | Fvar r -> Btype.set_kind r Fabsent; rem 803 | | _ -> rem 804 | else 805 | Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem))) 806 | methods (Ctype.newty Tnil) in 807 | begin try 808 | Ctype.unify val_env private_self 809 | (Ctype.newty (Tobject(self_methods, ref None))); 810 | Ctype.unify val_env public_self self_type 811 | with Ctype.Unify trace -> raise(Error(loc, val_env, Final_self_clash trace)) 812 | end; 813 | end; 814 | 815 | (* Typing of method bodies *) 816 | if !Clflags.principal then 817 | List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods; 818 | let fields = List.map Lazy.force (List.rev fields) in 819 | if !Clflags.principal then 820 | List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) 821 | methods; 822 | let meths = Meths.map (function (id, ty) -> id) !meths in 823 | 824 | (* Check for private methods made public *) 825 | let pub_meths' = 826 | List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent) 827 | (get_methods public_self) in 828 | let names = List.map (fun (x,_,_) -> x) in 829 | let l1 = names priv_meths and l2 = names pub_meths' in 830 | let added = List.filter (fun x -> List.mem x l1) l2 in 831 | if added <> [] then 832 | Location.prerr_warning loc (Warnings.Implicit_public_methods added); 833 | let sign = if final then sign else 834 | {sign with csig_self = Ctype.expand_head val_env public_self} in 835 | { 836 | cstr_self = pat; 837 | cstr_fields = fields; 838 | cstr_type = sign; 839 | cstr_meths = meths}, sign (* redondant, since already in cstr_type *) 840 | 841 | and class_expr cl_num val_env met_env scl = 842 | match scl.pcl_desc with 843 | Pcl_constr (lid, styl) -> 844 | let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid.txt in 845 | if Path.same decl.cty_path unbound_class then 846 | raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt)); 847 | let tyl = List.map 848 | (fun sty -> transl_simple_type val_env false sty) 849 | styl 850 | in 851 | let (params, clty) = 852 | Ctype.instance_class decl.cty_params decl.cty_type 853 | in 854 | let clty' = abbreviate_class_type path params clty in 855 | if List.length params <> List.length tyl then 856 | raise(Error(scl.pcl_loc, val_env, 857 | Parameter_arity_mismatch (lid.txt, List.length params, 858 | List.length tyl))); 859 | List.iter2 860 | (fun cty' ty -> 861 | let ty' = cty'.ctyp_type in 862 | try Ctype.unify val_env ty' ty with Ctype.Unify trace -> 863 | raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch trace))) 864 | tyl params; 865 | let cl = 866 | rc {cl_desc = Tcl_ident (path, lid, tyl); 867 | cl_loc = scl.pcl_loc; 868 | cl_type = clty'; 869 | cl_env = val_env; 870 | cl_attributes = scl.pcl_attributes; 871 | } 872 | in 873 | let (vals, meths, concrs) = extract_constraints clty in 874 | rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs); 875 | cl_loc = scl.pcl_loc; 876 | cl_type = clty'; 877 | cl_env = val_env; 878 | cl_attributes = []; (* attributes are kept on the inner cl node *) 879 | } 880 | | Pcl_structure cl_str -> 881 | let (desc, ty) = 882 | class_structure cl_num false val_env met_env scl.pcl_loc cl_str in 883 | rc {cl_desc = Tcl_structure desc; 884 | cl_loc = scl.pcl_loc; 885 | cl_type = Cty_signature ty; 886 | cl_env = val_env; 887 | cl_attributes = scl.pcl_attributes; 888 | } 889 | | Pcl_fun (l, Some default, spat, sbody) -> 890 | let loc = default.pexp_loc in 891 | let open Ast_helper in 892 | let scases = [ 893 | Exp.case 894 | (Pat.construct ~loc 895 | (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) 896 | (Some (Pat.var ~loc (mknoloc "*sth*")))) 897 | (Exp.ident ~loc (mknoloc (Longident.Lident "*sth*"))); 898 | 899 | Exp.case 900 | (Pat.construct ~loc 901 | (mknoloc (Longident.(Ldot (Lident "*predef*", "None")))) 902 | None) 903 | default; 904 | ] 905 | in 906 | let smatch = 907 | Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*"))) 908 | scases 909 | in 910 | let sfun = 911 | Cl.fun_ ~loc:scl.pcl_loc 912 | l None 913 | (Pat.var ~loc (mknoloc "*opt*")) 914 | (Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody) 915 | (* Note: we don't put the '#default' attribute, as it 916 | is not detected for class-level let bindings. See #5975.*) 917 | in 918 | class_expr cl_num val_env met_env sfun 919 | | Pcl_fun (l, None, spat, scl') -> 920 | if !Clflags.principal then Ctype.begin_def (); 921 | let (pat, pv, val_env', met_env) = 922 | Typecore.type_class_arg_pattern cl_num val_env met_env l spat 923 | in 924 | if !Clflags.principal then begin 925 | Ctype.end_def (); 926 | iter_pattern (fun {pat_type=ty} -> Ctype.generalize_structure ty) pat 927 | end; 928 | let pv = 929 | List.map 930 | begin fun (id, id_loc, id', ty) -> 931 | let path = Pident id' in 932 | (* do not mark the value as being used *) 933 | let vd = Env.find_value path val_env' in 934 | (id, id_loc, 935 | {exp_desc = 936 | Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd); 937 | exp_loc = Location.none; exp_extra = []; 938 | exp_type = Ctype.instance val_env' vd.val_type; 939 | exp_attributes = []; (* check *) 940 | exp_env = val_env'}) 941 | end 942 | pv 943 | in 944 | let not_function = function 945 | Cty_arrow _ -> false 946 | | _ -> true 947 | in 948 | let partial = 949 | Typecore.check_partial val_env pat.pat_type pat.pat_loc 950 | [{c_lhs=pat; 951 | c_guard=None; 952 | c_rhs = (* Dummy expression *) 953 | {exp_desc = Texp_constant (Asttypes.Const_int 1); 954 | exp_loc = Location.none; exp_extra = []; 955 | exp_type = Ctype.none; 956 | exp_attributes = []; 957 | exp_env = Env.empty }}] 958 | in 959 | Ctype.raise_nongen_level (); 960 | let cl = class_expr cl_num val_env' met_env scl' in 961 | Ctype.end_def (); 962 | if Btype.is_optional l && not_function cl.cl_type then 963 | Location.prerr_warning pat.pat_loc 964 | Warnings.Unerasable_optional_argument; 965 | rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial); 966 | cl_loc = scl.pcl_loc; 967 | cl_type = Cty_arrow 968 | (l, Ctype.instance_def pat.pat_type, cl.cl_type); 969 | cl_env = val_env; 970 | cl_attributes = scl.pcl_attributes; 971 | } 972 | | Pcl_apply (scl', sargs) -> 973 | if sargs = [] then 974 | Syntaxerr.ill_formed_ast scl.pcl_loc 975 | "Function application with no argument."; 976 | if !Clflags.principal then Ctype.begin_def (); 977 | let cl = class_expr cl_num val_env met_env scl' in 978 | if !Clflags.principal then begin 979 | Ctype.end_def (); 980 | generalize_class_type false cl.cl_type; 981 | end; 982 | let rec nonopt_labels ls ty_fun = 983 | match ty_fun with 984 | | Cty_arrow (l, _, ty_res) -> 985 | if Btype.is_optional l then nonopt_labels ls ty_res 986 | else nonopt_labels (l::ls) ty_res 987 | | _ -> ls 988 | in 989 | let ignore_labels = 990 | !Clflags.classic || 991 | let labels = nonopt_labels [] cl.cl_type in 992 | List.length labels = List.length sargs && 993 | List.for_all (fun (l,_) -> l = "") sargs && 994 | List.exists (fun l -> l <> "") labels && 995 | begin 996 | Location.prerr_warning cl.cl_loc Warnings.Labels_omitted; 997 | true 998 | end 999 | in 1000 | let rec type_args args omitted ty_fun ty_fun0 sargs more_sargs = 1001 | match ty_fun, ty_fun0 with 1002 | | Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0) 1003 | when sargs <> [] || more_sargs <> [] -> 1004 | let name = Btype.label_name l 1005 | and optional = 1006 | if Btype.is_optional l then Optional else Required in 1007 | let sargs, more_sargs, arg = 1008 | if ignore_labels && not (Btype.is_optional l) then begin 1009 | match sargs, more_sargs with 1010 | (l', sarg0)::_, _ -> 1011 | raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l')) 1012 | | _, (l', sarg0)::more_sargs -> 1013 | if l <> l' && l' <> "" then 1014 | raise(Error(sarg0.pexp_loc, val_env, 1015 | Apply_wrong_label l')) 1016 | else ([], more_sargs, 1017 | Some (type_argument val_env sarg0 ty ty0)) 1018 | | _ -> 1019 | assert false 1020 | end else try 1021 | let (l', sarg0, sargs, more_sargs) = 1022 | try 1023 | let (l', sarg0, sargs1, sargs2) = 1024 | Btype.extract_label name sargs 1025 | in (l', sarg0, sargs1 @ sargs2, more_sargs) 1026 | with Not_found -> 1027 | let (l', sarg0, sargs1, sargs2) = 1028 | Btype.extract_label name more_sargs 1029 | in (l', sarg0, sargs @ sargs1, sargs2) 1030 | in 1031 | if optional = Required && Btype.is_optional l' then 1032 | Location.prerr_warning sarg0.pexp_loc 1033 | (Warnings.Nonoptional_label l); 1034 | sargs, more_sargs, 1035 | if optional = Required || Btype.is_optional l' then 1036 | Some (type_argument val_env sarg0 ty ty0) 1037 | else 1038 | let ty' = extract_option_type val_env ty 1039 | and ty0' = extract_option_type val_env ty0 in 1040 | let arg = type_argument val_env sarg0 ty' ty0' in 1041 | Some (option_some arg) 1042 | with Not_found -> 1043 | sargs, more_sargs, 1044 | if Btype.is_optional l && 1045 | (List.mem_assoc "" sargs || List.mem_assoc "" more_sargs) 1046 | then 1047 | Some (option_none ty0 Location.none) 1048 | else None 1049 | in 1050 | let omitted = if arg = None then (l,ty0) :: omitted else omitted in 1051 | type_args ((l,arg,optional)::args) omitted ty_fun ty_fun0 1052 | sargs more_sargs 1053 | | _ -> 1054 | match sargs @ more_sargs with 1055 | (l, sarg0)::_ -> 1056 | if omitted <> [] then 1057 | raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l)) 1058 | else 1059 | raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type)) 1060 | | [] -> 1061 | (List.rev args, 1062 | List.fold_left 1063 | (fun ty_fun (l,ty) -> Cty_arrow(l,ty,ty_fun)) 1064 | ty_fun0 omitted) 1065 | in 1066 | let (args, cty) = 1067 | let (_, ty_fun0) = Ctype.instance_class [] cl.cl_type in 1068 | if ignore_labels then 1069 | type_args [] [] cl.cl_type ty_fun0 [] sargs 1070 | else 1071 | type_args [] [] cl.cl_type ty_fun0 sargs [] 1072 | in 1073 | rc {cl_desc = Tcl_apply (cl, args); 1074 | cl_loc = scl.pcl_loc; 1075 | cl_type = cty; 1076 | cl_env = val_env; 1077 | cl_attributes = scl.pcl_attributes; 1078 | } 1079 | | Pcl_let (rec_flag, sdefs, scl') -> 1080 | let (defs, val_env) = 1081 | try 1082 | Typecore.type_let val_env rec_flag sdefs None 1083 | with Ctype.Unify [(ty, _)] -> 1084 | raise(Error(scl.pcl_loc, val_env, Make_nongen_seltype ty)) 1085 | in 1086 | let (vals, met_env) = 1087 | List.fold_right 1088 | (fun (id, id_loc) (vals, met_env) -> 1089 | let path = Pident id in 1090 | (* do not mark the value as used *) 1091 | let vd = Env.find_value path val_env in 1092 | Ctype.begin_def (); 1093 | let expr = 1094 | {exp_desc = 1095 | Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd); 1096 | exp_loc = Location.none; exp_extra = []; 1097 | exp_type = Ctype.instance val_env vd.val_type; 1098 | exp_attributes = []; 1099 | exp_env = val_env; 1100 | } 1101 | in 1102 | Ctype.end_def (); 1103 | Ctype.generalize expr.exp_type; 1104 | let desc = 1105 | {val_type = expr.exp_type; val_kind = Val_ivar (Immutable, 1106 | cl_num); 1107 | val_attributes = []; 1108 | Types.val_loc = vd.Types.val_loc; 1109 | } 1110 | in 1111 | let id' = Ident.create (Ident.name id) in 1112 | ((id', id_loc, expr) 1113 | :: vals, 1114 | Env.add_value id' desc met_env)) 1115 | (let_bound_idents_with_loc defs) 1116 | ([], met_env) 1117 | in 1118 | let cl = class_expr cl_num val_env met_env scl' in 1119 | rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl); 1120 | cl_loc = scl.pcl_loc; 1121 | cl_type = cl.cl_type; 1122 | cl_env = val_env; 1123 | cl_attributes = scl.pcl_attributes; 1124 | } 1125 | | Pcl_constraint (scl', scty) -> 1126 | Ctype.begin_class_def (); 1127 | let context = Typetexp.narrow () in 1128 | let cl = class_expr cl_num val_env met_env scl' in 1129 | Typetexp.widen context; 1130 | let context = Typetexp.narrow () in 1131 | let clty = class_type val_env scty in 1132 | Typetexp.widen context; 1133 | Ctype.end_def (); 1134 | 1135 | limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type)) 1136 | cl.cl_type; 1137 | limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type)) 1138 | clty.cltyp_type; 1139 | 1140 | begin match 1141 | Includeclass.class_types val_env cl.cl_type clty.cltyp_type 1142 | with 1143 | [] -> () 1144 | | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error)) 1145 | end; 1146 | let (vals, meths, concrs) = extract_constraints clty.cltyp_type in 1147 | rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs); 1148 | cl_loc = scl.pcl_loc; 1149 | cl_type = snd (Ctype.instance_class [] clty.cltyp_type); 1150 | cl_env = val_env; 1151 | cl_attributes = scl.pcl_attributes; 1152 | } 1153 | | Pcl_extension ext -> 1154 | raise (Error_forward (Typetexp.error_of_extension ext)) 1155 | 1156 | (*******************************) 1157 | 1158 | (* Approximate the type of the constructor to allow recursive use *) 1159 | (* of optional parameters *) 1160 | 1161 | let var_option = Predef.type_option (Btype.newgenvar ()) 1162 | 1163 | let rec approx_declaration cl = 1164 | match cl.pcl_desc with 1165 | Pcl_fun (l, _, _, cl) -> 1166 | let arg = 1167 | if Btype.is_optional l then Ctype.instance_def var_option 1168 | else Ctype.newvar () in 1169 | Ctype.newty (Tarrow (l, arg, approx_declaration cl, Cok)) 1170 | | Pcl_let (_, _, cl) -> 1171 | approx_declaration cl 1172 | | Pcl_constraint (cl, _) -> 1173 | approx_declaration cl 1174 | | _ -> Ctype.newvar () 1175 | 1176 | let rec approx_description ct = 1177 | match ct.pcty_desc with 1178 | Pcty_arrow (l, _, ct) -> 1179 | let arg = 1180 | if Btype.is_optional l then Ctype.instance_def var_option 1181 | else Ctype.newvar () in 1182 | Ctype.newty (Tarrow (l, arg, approx_description ct, Cok)) 1183 | | _ -> Ctype.newvar () 1184 | 1185 | (*******************************) 1186 | 1187 | let temp_abbrev loc env id arity = 1188 | let params = ref [] in 1189 | for _i = 1 to arity do 1190 | params := Ctype.newvar () :: !params 1191 | done; 1192 | let ty = Ctype.newobj (Ctype.newvar ()) in 1193 | let env = 1194 | Env.add_type ~check:true id 1195 | {type_params = !params; 1196 | type_arity = arity; 1197 | type_kind = Type_abstract; 1198 | type_private = Public; 1199 | type_manifest = Some ty; 1200 | type_variance = Misc.replicate_list Variance.full arity; 1201 | type_newtype_level = None; 1202 | type_loc = loc; 1203 | type_attributes = []; (* or keep attrs from the class decl? *) 1204 | } 1205 | env 1206 | in 1207 | (!params, ty, env) 1208 | 1209 | let initial_env define_class approx 1210 | (res, env) (cl, id, ty_id, obj_id, cl_id) = 1211 | (* Temporary abbreviations *) 1212 | let arity = List.length cl.pci_params in 1213 | let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity in 1214 | let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity in 1215 | 1216 | (* Temporary type for the class constructor *) 1217 | let constr_type = approx cl.pci_expr in 1218 | if !Clflags.principal then Ctype.generalize_spine constr_type; 1219 | let dummy_cty = 1220 | Cty_signature 1221 | { csig_self = Ctype.newvar (); 1222 | csig_vars = Vars.empty; 1223 | csig_concr = Concr.empty; 1224 | csig_inher = [] } 1225 | in 1226 | let dummy_class = 1227 | {Types.cty_params = []; (* Dummy value *) 1228 | cty_variance = []; 1229 | cty_type = dummy_cty; (* Dummy value *) 1230 | cty_path = unbound_class; 1231 | cty_new = 1232 | begin match cl.pci_virt with 1233 | | Virtual -> None 1234 | | Concrete -> Some constr_type 1235 | end; 1236 | cty_loc = Location.none; 1237 | cty_attributes = []; 1238 | } 1239 | in 1240 | let env = 1241 | Env.add_cltype ty_id 1242 | {clty_params = []; (* Dummy value *) 1243 | clty_variance = []; 1244 | clty_type = dummy_cty; (* Dummy value *) 1245 | clty_path = unbound_class; 1246 | clty_loc = Location.none; 1247 | clty_attributes = []; 1248 | } 1249 | ( 1250 | if define_class then 1251 | Env.add_class id dummy_class env 1252 | else 1253 | env 1254 | ) 1255 | in 1256 | ((cl, id, ty_id, 1257 | obj_id, obj_params, obj_ty, 1258 | cl_id, cl_params, cl_ty, 1259 | constr_type, dummy_class)::res, 1260 | env) 1261 | 1262 | let class_infos define_class kind 1263 | (cl, id, ty_id, 1264 | obj_id, obj_params, obj_ty, 1265 | cl_id, cl_params, cl_ty, 1266 | constr_type, dummy_class) 1267 | (res, env) = 1268 | 1269 | reset_type_variables (); 1270 | Ctype.begin_class_def (); 1271 | 1272 | (* Introduce class parameters *) 1273 | let ci_params = 1274 | let make_param (sty, v) = 1275 | try 1276 | (transl_type_param env sty, v) 1277 | with Already_bound -> 1278 | raise(Error(sty.ptyp_loc, env, Repeated_parameter)) 1279 | in 1280 | List.map make_param cl.pci_params 1281 | in 1282 | let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in 1283 | 1284 | (* Allow self coercions (only for class declarations) *) 1285 | let coercion_locs = ref [] in 1286 | 1287 | (* Type the class expression *) 1288 | let (expr, typ) = 1289 | try 1290 | Typecore.self_coercion := 1291 | (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion; 1292 | let res = kind env cl.pci_expr in 1293 | Typecore.self_coercion := List.tl !Typecore.self_coercion; 1294 | res 1295 | with exn -> 1296 | Typecore.self_coercion := []; raise exn 1297 | in 1298 | 1299 | Ctype.end_def (); 1300 | 1301 | let sty = Ctype.self_type typ in 1302 | 1303 | (* First generalize the type of the dummy method (cf PR#6123) *) 1304 | let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in 1305 | List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty) 1306 | fields; 1307 | (* Generalize the row variable *) 1308 | let rv = Ctype.row_variable sty in 1309 | List.iter (Ctype.limited_generalize rv) params; 1310 | limited_generalize rv typ; 1311 | 1312 | (* Check the abbreviation for the object type *) 1313 | let (obj_params', obj_type) = Ctype.instance_class params typ in 1314 | let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in 1315 | begin 1316 | let ty = Ctype.self_type obj_type in 1317 | Ctype.hide_private_methods ty; 1318 | Ctype.close_object ty; 1319 | begin try 1320 | List.iter2 (Ctype.unify env) obj_params obj_params' 1321 | with Ctype.Unify _ -> 1322 | raise(Error(cl.pci_loc, env, 1323 | Bad_parameters (obj_id, constr, 1324 | Ctype.newconstr (Path.Pident obj_id) 1325 | obj_params'))) 1326 | end; 1327 | begin try 1328 | Ctype.unify env ty constr 1329 | with Ctype.Unify _ -> 1330 | raise(Error(cl.pci_loc, env, 1331 | Abbrev_type_clash (constr, ty, Ctype.expand_head env constr))) 1332 | end 1333 | end; 1334 | 1335 | (* Check the other temporary abbreviation (#-type) *) 1336 | begin 1337 | let (cl_params', cl_type) = Ctype.instance_class params typ in 1338 | let ty = Ctype.self_type cl_type in 1339 | Ctype.hide_private_methods ty; 1340 | Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty; 1341 | begin try 1342 | List.iter2 (Ctype.unify env) cl_params cl_params' 1343 | with Ctype.Unify _ -> 1344 | raise(Error(cl.pci_loc, env, 1345 | Bad_parameters (cl_id, 1346 | Ctype.newconstr (Path.Pident cl_id) 1347 | cl_params, 1348 | Ctype.newconstr (Path.Pident cl_id) 1349 | cl_params'))) 1350 | end; 1351 | begin try 1352 | Ctype.unify env ty cl_ty 1353 | with Ctype.Unify _ -> 1354 | let constr = Ctype.newconstr (Path.Pident cl_id) params in 1355 | raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty))) 1356 | end 1357 | end; 1358 | 1359 | (* Type of the class constructor *) 1360 | begin try 1361 | Ctype.unify env 1362 | (constructor_type constr obj_type) 1363 | (Ctype.instance env constr_type) 1364 | with Ctype.Unify trace -> 1365 | raise(Error(cl.pci_loc, env, 1366 | Constructor_type_mismatch (cl.pci_name.txt, trace))) 1367 | end; 1368 | 1369 | (* Class and class type temporary definitions *) 1370 | let cty_variance = List.map (fun _ -> Variance.full) params in 1371 | let cltydef = 1372 | {clty_params = params; clty_type = class_body typ; 1373 | clty_variance = cty_variance; 1374 | clty_path = Path.Pident obj_id; 1375 | clty_loc = cl.pci_loc; 1376 | clty_attributes = cl.pci_attributes; 1377 | } 1378 | and clty = 1379 | {cty_params = params; cty_type = typ; 1380 | cty_variance = cty_variance; 1381 | cty_path = Path.Pident obj_id; 1382 | cty_new = 1383 | begin match cl.pci_virt with 1384 | | Virtual -> None 1385 | | Concrete -> Some constr_type 1386 | end; 1387 | cty_loc = cl.pci_loc; 1388 | cty_attributes = cl.pci_attributes; 1389 | } 1390 | in 1391 | dummy_class.cty_type <- typ; 1392 | let env = 1393 | Env.add_cltype ty_id cltydef ( 1394 | if define_class then Env.add_class id clty env else env) 1395 | in 1396 | 1397 | if cl.pci_virt = Concrete then begin 1398 | let sign = Ctype.signature_of_class_type typ in 1399 | let mets = virtual_methods sign in 1400 | let vals = 1401 | Vars.fold 1402 | (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) 1403 | sign.csig_vars [] in 1404 | if mets <> [] || vals <> [] then 1405 | raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets, vals))); 1406 | end; 1407 | 1408 | (* Misc. *) 1409 | let arity = Ctype.class_type_arity typ in 1410 | let pub_meths = 1411 | let (fields, _) = 1412 | Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty)) 1413 | in 1414 | List.map (function (lab, _, _) -> lab) fields 1415 | in 1416 | 1417 | (* Final definitions *) 1418 | let (params', typ') = Ctype.instance_class params typ in 1419 | let cltydef = 1420 | {clty_params = params'; clty_type = class_body typ'; 1421 | clty_variance = cty_variance; 1422 | clty_path = Path.Pident obj_id; 1423 | clty_loc = cl.pci_loc; 1424 | clty_attributes = cl.pci_attributes; 1425 | } 1426 | and clty = 1427 | {cty_params = params'; cty_type = typ'; 1428 | cty_variance = cty_variance; 1429 | cty_path = Path.Pident obj_id; 1430 | cty_new = 1431 | begin match cl.pci_virt with 1432 | | Virtual -> None 1433 | | Concrete -> Some (Ctype.instance env constr_type) 1434 | end; 1435 | cty_loc = cl.pci_loc; 1436 | cty_attributes = cl.pci_attributes; 1437 | } 1438 | in 1439 | let obj_abbr = 1440 | {type_params = obj_params; 1441 | type_arity = List.length obj_params; 1442 | type_kind = Type_abstract; 1443 | type_private = Public; 1444 | type_manifest = Some obj_ty; 1445 | type_variance = List.map (fun _ -> Variance.full) obj_params; 1446 | type_newtype_level = None; 1447 | type_loc = cl.pci_loc; 1448 | type_attributes = []; (* or keep attrs from cl? *) 1449 | } 1450 | in 1451 | let (cl_params, cl_ty) = 1452 | Ctype.instance_parameterized_type params (Ctype.self_type typ) 1453 | in 1454 | Ctype.hide_private_methods cl_ty; 1455 | Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty; 1456 | let cl_abbr = 1457 | {type_params = cl_params; 1458 | type_arity = List.length cl_params; 1459 | type_kind = Type_abstract; 1460 | type_private = Public; 1461 | type_manifest = Some cl_ty; 1462 | type_variance = List.map (fun _ -> Variance.full) cl_params; 1463 | type_newtype_level = None; 1464 | type_loc = cl.pci_loc; 1465 | type_attributes = []; (* or keep attrs from cl? *) 1466 | } 1467 | in 1468 | ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params, 1469 | arity, pub_meths, List.rev !coercion_locs, expr) :: res, 1470 | env) 1471 | 1472 | let final_decl env define_class 1473 | (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params, 1474 | arity, pub_meths, coe, expr) = 1475 | 1476 | begin try Ctype.collapse_conj_params env clty.cty_params 1477 | with Ctype.Unify trace -> 1478 | raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace))) 1479 | end; 1480 | 1481 | List.iter Ctype.generalize clty.cty_params; 1482 | generalize_class_type true clty.cty_type; 1483 | Misc.may Ctype.generalize clty.cty_new; 1484 | List.iter Ctype.generalize obj_abbr.type_params; 1485 | Misc.may Ctype.generalize obj_abbr.type_manifest; 1486 | List.iter Ctype.generalize cl_abbr.type_params; 1487 | Misc.may Ctype.generalize cl_abbr.type_manifest; 1488 | 1489 | if not (closed_class clty) then 1490 | raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty))); 1491 | 1492 | begin match 1493 | Ctype.closed_class clty.cty_params 1494 | (Ctype.signature_of_class_type clty.cty_type) 1495 | with 1496 | None -> () 1497 | | Some reason -> 1498 | let printer = 1499 | if define_class 1500 | then function ppf -> Printtyp.class_declaration id ppf clty 1501 | else function ppf -> Printtyp.cltype_declaration id ppf cltydef 1502 | in 1503 | raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason))) 1504 | end; 1505 | 1506 | (id, cl.pci_name, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, 1507 | arity, pub_meths, coe, expr, 1508 | { ci_loc = cl.pci_loc; 1509 | ci_virt = cl.pci_virt; 1510 | ci_params = ci_params; 1511 | (* TODO : check that we have the correct use of identifiers *) 1512 | ci_id_name = cl.pci_name; 1513 | ci_id_class = id; 1514 | ci_id_class_type = ty_id; 1515 | ci_id_object = obj_id; 1516 | ci_id_typesharp = cl_id; 1517 | ci_expr = expr; 1518 | ci_decl = clty; 1519 | ci_type_decl = cltydef; 1520 | ci_attributes = cl.pci_attributes; 1521 | }) 1522 | (* (cl.pci_variance, cl.pci_loc)) *) 1523 | 1524 | let extract_type_decls 1525 | (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, 1526 | arity, pub_meths, coe, expr, required) decls = 1527 | (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls 1528 | 1529 | let merge_type_decls 1530 | (id, id_loc, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr, 1531 | arity, pub_meths, coe, expr, req) (obj_abbr, cl_abbr, clty, cltydef) = 1532 | (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, 1533 | arity, pub_meths, coe, expr, req) 1534 | 1535 | let final_env define_class env 1536 | (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, 1537 | arity, pub_meths, coe, expr, req) = 1538 | (* Add definitions after cleaning them *) 1539 | Env.add_type ~check:true obj_id 1540 | (Subst.type_declaration Subst.identity obj_abbr) ( 1541 | Env.add_type ~check:true cl_id 1542 | (Subst.type_declaration Subst.identity cl_abbr) ( 1543 | Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) ( 1544 | if define_class then 1545 | Env.add_class id (Subst.class_declaration Subst.identity clty) env 1546 | else env))) 1547 | 1548 | (* Check that #c is coercible to c if there is a self-coercion *) 1549 | let check_coercions env 1550 | (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, 1551 | arity, pub_meths, coercion_locs, expr, req) = 1552 | begin match coercion_locs with [] -> () 1553 | | loc :: _ -> 1554 | let cl_ty, obj_ty = 1555 | match cl_abbr.type_manifest, obj_abbr.type_manifest with 1556 | Some cl_ab, Some obj_ab -> 1557 | let cl_params, cl_ty = 1558 | Ctype.instance_parameterized_type cl_abbr.type_params cl_ab 1559 | and obj_params, obj_ty = 1560 | Ctype.instance_parameterized_type obj_abbr.type_params obj_ab 1561 | in 1562 | List.iter2 (Ctype.unify env) cl_params obj_params; 1563 | cl_ty, obj_ty 1564 | | _ -> assert false 1565 | in 1566 | begin try Ctype.subtype env cl_ty obj_ty () 1567 | with Ctype.Subtype (tr1, tr2) -> 1568 | raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2))) 1569 | end; 1570 | if not (Ctype.opened_object cl_ty) then 1571 | raise(Error(loc, env, Cannot_coerce_self obj_ty)) 1572 | end; 1573 | (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, 1574 | arity, pub_meths, req) 1575 | 1576 | (*******************************) 1577 | 1578 | let type_classes define_class approx kind env cls = 1579 | let cls = 1580 | List.map 1581 | (function cl -> 1582 | (cl, 1583 | Ident.create cl.pci_name.txt, Ident.create cl.pci_name.txt, 1584 | Ident.create cl.pci_name.txt, Ident.create ("#" ^ cl.pci_name.txt))) 1585 | cls 1586 | in 1587 | Ctype.init_def (Ident.current_time ()); 1588 | Ctype.begin_class_def (); 1589 | let (res, env) = 1590 | List.fold_left (initial_env define_class approx) ([], env) cls 1591 | in 1592 | let (res, env) = 1593 | List.fold_right (class_infos define_class kind) res ([], env) 1594 | in 1595 | Ctype.end_def (); 1596 | let res = List.rev_map (final_decl env define_class) res in 1597 | let decls = List.fold_right extract_type_decls res [] in 1598 | let decls = Typedecl.compute_variance_decls env decls in 1599 | let res = List.map2 merge_type_decls res decls in 1600 | let env = List.fold_left (final_env define_class) env res in 1601 | let res = List.map (check_coercions env) res in 1602 | (res, env) 1603 | 1604 | let class_num = ref 0 1605 | let class_declaration env sexpr = 1606 | incr class_num; 1607 | let expr = class_expr (string_of_int !class_num) env env sexpr in 1608 | (expr, expr.cl_type) 1609 | 1610 | let class_description env sexpr = 1611 | let expr = class_type env sexpr in 1612 | (expr, expr.cltyp_type) 1613 | 1614 | let class_declarations env cls = 1615 | type_classes true approx_declaration class_declaration env cls 1616 | 1617 | let class_descriptions env cls = 1618 | type_classes true approx_description class_description env cls 1619 | 1620 | let class_type_declarations env cls = 1621 | let (decl, env) = 1622 | type_classes false approx_description class_description env cls 1623 | in 1624 | (List.map 1625 | (function 1626 | (_, id_loc, _, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, 1627 | _, _, ci) -> 1628 | (ty_id, id_loc, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci)) 1629 | decl, 1630 | env) 1631 | 1632 | let rec unify_parents env ty cl = 1633 | match cl.cl_desc with 1634 | Tcl_ident (p, _, _) -> 1635 | begin try 1636 | let decl = Env.find_class p env in 1637 | let _, body = Ctype.find_cltype_for_path env decl.cty_path in 1638 | Ctype.unify env ty (Ctype.instance env body) 1639 | with 1640 | Not_found -> () 1641 | | exn -> assert false 1642 | end 1643 | | Tcl_structure st -> unify_parents_struct env ty st 1644 | | Tcl_fun (_, _, _, cl, _) 1645 | | Tcl_apply (cl, _) 1646 | | Tcl_let (_, _, _, cl) 1647 | | Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl 1648 | and unify_parents_struct env ty st = 1649 | List.iter 1650 | (function {cf_desc = Tcf_inherit (_, cl, _, _, _)} -> unify_parents env ty cl 1651 | | _ -> ()) 1652 | st.cstr_fields 1653 | 1654 | let type_object env loc s = 1655 | incr class_num; 1656 | let (desc, sign) = 1657 | class_structure (string_of_int !class_num) true env env loc s in 1658 | let sty = Ctype.expand_head env sign.csig_self in 1659 | Ctype.hide_private_methods sty; 1660 | let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in 1661 | let meths = List.map (fun (s,_,_) -> s) fields in 1662 | unify_parents_struct env sign.csig_self desc; 1663 | (desc, sign, meths) 1664 | 1665 | let () = 1666 | Typecore.type_object := type_object 1667 | 1668 | (*******************************) 1669 | 1670 | (* Approximate the class declaration as class ['params] id = object end *) 1671 | let approx_class sdecl = 1672 | let open Ast_helper in 1673 | let self' = Typ.any () in 1674 | let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in 1675 | { sdecl with pci_expr = clty' } 1676 | 1677 | let approx_class_declarations env sdecls = 1678 | fst (class_type_declarations env (List.map approx_class sdecls)) 1679 | 1680 | (*******************************) 1681 | 1682 | (* Error report *) 1683 | 1684 | open Format 1685 | 1686 | let report_error env ppf = function 1687 | | Repeated_parameter -> 1688 | fprintf ppf "A type parameter occurs several times" 1689 | | Unconsistent_constraint trace -> 1690 | fprintf ppf "The class constraints are not consistent.@."; 1691 | Printtyp.report_unification_error ppf env trace 1692 | (fun ppf -> fprintf ppf "Type") 1693 | (fun ppf -> fprintf ppf "is not compatible with type") 1694 | | Field_type_mismatch (k, m, trace) -> 1695 | Printtyp.report_unification_error ppf env trace 1696 | (function ppf -> 1697 | fprintf ppf "The %s %s@ has type" k m) 1698 | (function ppf -> 1699 | fprintf ppf "but is expected to have type") 1700 | | Structure_expected clty -> 1701 | fprintf ppf 1702 | "@[This class expression is not a class structure; it has type@ %a@]" 1703 | Printtyp.class_type clty 1704 | | Cannot_apply clty -> 1705 | fprintf ppf 1706 | "This class expression is not a class function, it cannot be applied" 1707 | | Apply_wrong_label l -> 1708 | let mark_label = function 1709 | | "" -> "out label" 1710 | | l -> sprintf " label ~%s" l in 1711 | fprintf ppf "This argument cannot be applied with%s" (mark_label l) 1712 | | Pattern_type_clash ty -> 1713 | (* XXX Trace *) 1714 | (* XXX Revoir message d'erreur *) 1715 | Printtyp.reset_and_mark_loops ty; 1716 | fprintf ppf "@[%s@ %a@]" 1717 | "This pattern cannot match self: it only matches values of type" 1718 | Printtyp.type_expr ty 1719 | | Unbound_class_2 cl -> 1720 | fprintf ppf "@[The class@ %a@ is not yet completely defined@]" 1721 | Printtyp.longident cl 1722 | | Unbound_class_type_2 cl -> 1723 | fprintf ppf "@[The class type@ %a@ is not yet completely defined@]" 1724 | Printtyp.longident cl 1725 | | Abbrev_type_clash (abbrev, actual, expected) -> 1726 | (* XXX Afficher une trace ? *) 1727 | Printtyp.reset_and_mark_loops_list [abbrev; actual; expected]; 1728 | fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \ 1729 | but is used with type@ %a@]" 1730 | Printtyp.type_expr abbrev 1731 | Printtyp.type_expr actual 1732 | Printtyp.type_expr expected 1733 | | Constructor_type_mismatch (c, trace) -> 1734 | Printtyp.report_unification_error ppf env trace 1735 | (function ppf -> 1736 | fprintf ppf "The expression \"new %s\" has type" c) 1737 | (function ppf -> 1738 | fprintf ppf "but is used with type") 1739 | | Virtual_class (cl, imm, mets, vals) -> 1740 | let print_mets ppf mets = 1741 | List.iter (function met -> fprintf ppf "@ %s" met) mets in 1742 | let missings = 1743 | match mets, vals with 1744 | [], _ -> "variables" 1745 | | _, [] -> "methods" 1746 | | _ -> "methods and variables" 1747 | in 1748 | let print_msg ppf = 1749 | if imm then fprintf ppf "This object has virtual %s" missings 1750 | else if cl then fprintf ppf "This class should be virtual" 1751 | else fprintf ppf "This class type should be virtual" 1752 | in 1753 | fprintf ppf 1754 | "@[%t.@ @[<2>The following %s are undefined :%a@]@]" 1755 | print_msg missings print_mets (mets @ vals) 1756 | | Parameter_arity_mismatch(lid, expected, provided) -> 1757 | fprintf ppf 1758 | "@[The class constructor %a@ expects %i type argument(s),@ \ 1759 | but is here applied to %i type argument(s)@]" 1760 | Printtyp.longident lid expected provided 1761 | | Parameter_mismatch trace -> 1762 | Printtyp.report_unification_error ppf env trace 1763 | (function ppf -> 1764 | fprintf ppf "The type parameter") 1765 | (function ppf -> 1766 | fprintf ppf "does not meet its constraint: it should be") 1767 | | Bad_parameters (id, params, cstrs) -> 1768 | Printtyp.reset_and_mark_loops_list [params; cstrs]; 1769 | fprintf ppf 1770 | "@[The abbreviation %a@ is used with parameters@ %a@ \ 1771 | wich are incompatible with constraints@ %a@]" 1772 | Printtyp.ident id Printtyp.type_expr params Printtyp.type_expr cstrs 1773 | | Class_match_failure error -> 1774 | Includeclass.report_error ppf error 1775 | | Unbound_val lab -> 1776 | fprintf ppf "Unbound instance variable %s" lab 1777 | | Unbound_type_var (printer, reason) -> 1778 | let print_common ppf kind ty0 real lab ty = 1779 | let ty1 = 1780 | if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in 1781 | Printtyp.mark_loops ty1; 1782 | fprintf ppf 1783 | "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound" 1784 | kind lab Printtyp.type_expr ty Printtyp.type_expr ty0 1785 | in 1786 | let print_reason ppf = function 1787 | | Ctype.CC_Method (ty0, real, lab, ty) -> 1788 | print_common ppf "method" ty0 real lab ty 1789 | | Ctype.CC_Value (ty0, real, lab, ty) -> 1790 | print_common ppf "instance variable" ty0 real lab ty 1791 | in 1792 | Printtyp.reset (); 1793 | fprintf ppf 1794 | "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \ 1795 | @[%a@]@]" 1796 | printer print_reason reason 1797 | | Make_nongen_seltype ty -> 1798 | fprintf ppf 1799 | "@[@[Self type should not occur in the non-generic type@;<1 2>\ 1800 | %a@]@,\ 1801 | It would escape the scope of its class@]" 1802 | Printtyp.type_scheme ty 1803 | | Non_generalizable_class (id, clty) -> 1804 | fprintf ppf 1805 | "@[The type of this class,@ %a,@ \ 1806 | contains type variables that cannot be generalized@]" 1807 | (Printtyp.class_declaration id) clty 1808 | | Cannot_coerce_self ty -> 1809 | fprintf ppf 1810 | "@[The type of self cannot be coerced to@ \ 1811 | the type of the current class:@ %a.@.\ 1812 | Some occurrences are contravariant@]" 1813 | Printtyp.type_scheme ty 1814 | | Non_collapsable_conjunction (id, clty, trace) -> 1815 | fprintf ppf 1816 | "@[The type of this class,@ %a,@ \ 1817 | contains non-collapsible conjunctive types in constraints@]" 1818 | (Printtyp.class_declaration id) clty; 1819 | Printtyp.report_unification_error ppf env trace 1820 | (fun ppf -> fprintf ppf "Type") 1821 | (fun ppf -> fprintf ppf "is not compatible with type") 1822 | | Final_self_clash trace -> 1823 | Printtyp.report_unification_error ppf env trace 1824 | (function ppf -> 1825 | fprintf ppf "This object is expected to have type") 1826 | (function ppf -> 1827 | fprintf ppf "but actually has type") 1828 | | Mutability_mismatch (lab, mut) -> 1829 | let mut1, mut2 = 1830 | if mut = Immutable then "mutable", "immutable" 1831 | else "immutable", "mutable" in 1832 | fprintf ppf 1833 | "@[The instance variable is %s;@ it cannot be redefined as %s@]" 1834 | mut1 mut2 1835 | | No_overriding (_, "") -> 1836 | fprintf ppf "@[This inheritance does not override any method@ %s@]" 1837 | "instance variable" 1838 | | No_overriding (kind, name) -> 1839 | fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name 1840 | | Duplicate (kind, name) -> 1841 | fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]" 1842 | kind name 1843 | 1844 | let report_error env ppf err = 1845 | Printtyp.wrap_printing_env env (fun () -> report_error env ppf err) 1846 | 1847 | let () = 1848 | Location.register_error_of_exn 1849 | (function 1850 | | Error (loc, env, err) -> 1851 | Some (Location.error_of_printer loc (report_error env) err) 1852 | | Error_forward err -> 1853 | Some err 1854 | | _ -> 1855 | None 1856 | ) 1857 | -------------------------------------------------------------------------------- /src/typing/PPTypeclass.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | open Asttypes 14 | open Types 15 | open Format 16 | 17 | val class_declarations: 18 | Env.t -> Parsetree.class_declaration list -> 19 | (Ident.t * string loc * class_declaration * 20 | Ident.t * class_type_declaration * 21 | Ident.t * type_declaration * 22 | Ident.t * type_declaration * 23 | int * string list * Typedtree.class_declaration) list * Env.t 24 | 25 | (* 26 | and class_declaration = 27 | (class_expr, Types.class_declaration) class_infos 28 | *) 29 | 30 | val class_descriptions: 31 | Env.t -> Parsetree.class_description list -> 32 | (Ident.t * string loc * class_declaration * 33 | Ident.t * class_type_declaration * 34 | Ident.t * type_declaration * 35 | Ident.t * type_declaration * 36 | int * string list * Typedtree.class_description) list * Env.t 37 | 38 | (* 39 | and class_description = 40 | (class_type, unit) class_infos 41 | *) 42 | 43 | val class_type_declarations: 44 | Env.t -> Parsetree.class_description list -> 45 | (Ident.t * string loc * class_type_declaration * 46 | Ident.t * type_declaration * 47 | Ident.t * type_declaration * 48 | Typedtree.class_type_declaration) list * Env.t 49 | 50 | (* 51 | and class_type_declaration = 52 | (class_type, Types.class_type_declaration) class_infos 53 | *) 54 | 55 | val approx_class_declarations: 56 | Env.t -> Parsetree.class_description list -> 57 | (Ident.t * string loc * class_type_declaration * 58 | Ident.t * type_declaration * 59 | Ident.t * type_declaration * 60 | Typedtree.class_type_declaration) list 61 | 62 | val virtual_methods: Types.class_signature -> label list 63 | 64 | (* 65 | val type_classes : 66 | bool -> 67 | ('a -> Types.type_expr) -> 68 | (Env.t -> 'a -> 'b * Types.class_type) -> 69 | Env.t -> 70 | 'a Parsetree.class_infos list -> 71 | ( Ident.t * Types.class_declaration * 72 | Ident.t * Types.class_type_declaration * 73 | Ident.t * Types.type_declaration * 74 | Ident.t * Types.type_declaration * 75 | int * string list * 'b * 'b Typedtree.class_infos) 76 | list * Env.t 77 | *) 78 | 79 | type error = 80 | Unconsistent_constraint of (type_expr * type_expr) list 81 | | Field_type_mismatch of string * string * (type_expr * type_expr) list 82 | | Structure_expected of class_type 83 | | Cannot_apply of class_type 84 | | Apply_wrong_label of label 85 | | Pattern_type_clash of type_expr 86 | | Repeated_parameter 87 | | Unbound_class_2 of Longident.t 88 | | Unbound_class_type_2 of Longident.t 89 | | Abbrev_type_clash of type_expr * type_expr * type_expr 90 | | Constructor_type_mismatch of string * (type_expr * type_expr) list 91 | | Virtual_class of bool * bool * string list * string list 92 | | Parameter_arity_mismatch of Longident.t * int * int 93 | | Parameter_mismatch of (type_expr * type_expr) list 94 | | Bad_parameters of Ident.t * type_expr * type_expr 95 | | Class_match_failure of Ctype.class_match_failure list 96 | | Unbound_val of string 97 | | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure 98 | | Make_nongen_seltype of type_expr 99 | | Non_generalizable_class of Ident.t * Types.class_declaration 100 | | Cannot_coerce_self of type_expr 101 | | Non_collapsable_conjunction of 102 | Ident.t * Types.class_declaration * (type_expr * type_expr) list 103 | | Final_self_clash of (type_expr * type_expr) list 104 | | Mutability_mismatch of string * mutable_flag 105 | | No_overriding of string * string 106 | | Duplicate of string * string 107 | 108 | exception Error of Location.t * Env.t * error 109 | exception Error_forward of Location.error 110 | 111 | val report_error : Env.t -> formatter -> error -> unit 112 | -------------------------------------------------------------------------------- /src/typing/PPTypecore.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* Type inference for the core language *) 14 | 15 | open Asttypes 16 | open Types 17 | open Format 18 | 19 | val is_nonexpansive: Typedtree.expression -> bool 20 | 21 | val type_binding: 22 | Env.t -> rec_flag -> 23 | Parsetree.value_binding list -> 24 | Annot.ident option -> 25 | Typedtree.value_binding list * Env.t 26 | val type_let: 27 | Env.t -> rec_flag -> 28 | Parsetree.value_binding list -> 29 | Annot.ident option -> 30 | Typedtree.value_binding list * Env.t 31 | val type_expression: 32 | Env.t -> Parsetree.expression -> Typedtree.expression 33 | val type_class_arg_pattern: 34 | string -> Env.t -> Env.t -> label -> Parsetree.pattern -> 35 | Typedtree.pattern * (Ident.t * string loc * Ident.t * type_expr) list * 36 | Env.t * Env.t 37 | val type_self_pattern: 38 | string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern -> 39 | Typedtree.pattern * 40 | (Ident.t * type_expr) Meths.t ref * 41 | (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) 42 | Vars.t ref * 43 | Env.t * Env.t * Env.t 44 | val check_partial: 45 | ?lev:int -> Env.t -> type_expr -> 46 | Location.t -> Typedtree.case list -> Typedtree.partial 47 | val type_expect: 48 | ?in_function:(Location.t * type_expr) -> 49 | Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression 50 | val type_exp: 51 | Env.t -> Parsetree.expression -> Typedtree.expression 52 | val type_approx: 53 | Env.t -> Parsetree.expression -> type_expr 54 | val type_argument: 55 | Env.t -> Parsetree.expression -> 56 | type_expr -> type_expr -> Typedtree.expression 57 | 58 | val option_some: Typedtree.expression -> Typedtree.expression 59 | val option_none: type_expr -> Location.t -> Typedtree.expression 60 | val extract_option_type: Env.t -> type_expr -> type_expr 61 | val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit 62 | val generalizable: int -> type_expr -> bool 63 | val reset_delayed_checks: unit -> unit 64 | val force_delayed_checks: unit -> unit 65 | 66 | val self_coercion : (Path.t * Location.t list ref) list ref 67 | 68 | type error = 69 | Polymorphic_label of Longident.t 70 | | Constructor_arity_mismatch of Longident.t * int * int 71 | | Label_mismatch of Longident.t * (type_expr * type_expr) list 72 | | Pattern_type_clash of (type_expr * type_expr) list 73 | | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list 74 | | Multiply_bound_variable of string 75 | | Orpat_vars of Ident.t 76 | | Expr_type_clash of (type_expr * type_expr) list 77 | | Apply_non_function of type_expr 78 | | Apply_wrong_label of label * type_expr 79 | | Label_multiply_defined of string 80 | | Label_missing of Ident.t list 81 | | Label_not_mutable of Longident.t 82 | | Wrong_name of string * type_expr * string * Path.t * Longident.t 83 | | Name_type_mismatch of 84 | string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list 85 | | Invalid_format of string 86 | | Undefined_method of type_expr * string 87 | | Undefined_inherited_method of string 88 | | Virtual_class of Longident.t 89 | | Private_type of type_expr 90 | | Private_label of Longident.t * type_expr 91 | | Unbound_instance_variable of string 92 | | Instance_variable_not_mutable of bool * string 93 | | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list 94 | | Outside_class 95 | | Value_multiply_overridden of string 96 | | Coercion_failure of 97 | type_expr * type_expr * (type_expr * type_expr) list * bool 98 | | Too_many_arguments of bool * type_expr 99 | | Abstract_wrong_label of label * type_expr 100 | | Scoping_let_module of string * type_expr 101 | | Masked_instance_variable of Longident.t 102 | | Not_a_variant_type of Longident.t 103 | | Incoherent_label_order 104 | | Less_general of string * (type_expr * type_expr) list 105 | | Modules_not_allowed 106 | | Cannot_infer_signature 107 | | Not_a_packed_module of type_expr 108 | | Recursive_local_constraint of (type_expr * type_expr) list 109 | | Unexpected_existential 110 | | Unqualified_gadt_pattern of Path.t * string 111 | | Invalid_interval 112 | | Invalid_for_loop_index 113 | | No_value_clauses 114 | | Exception_pattern_below_toplevel 115 | 116 | exception Error of Location.t * Env.t * error 117 | exception Error_forward of Location.error 118 | 119 | val report_error: Env.t -> formatter -> error -> unit 120 | (* Deprecated. Use Location.{error_of_exn, report_error}. *) 121 | 122 | (* Forward declaration, to be filled in by Typemod.type_module *) 123 | val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref 124 | (* Forward declaration, to be filled in by Typemod.type_open *) 125 | val type_open: 126 | (override_flag -> Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) 127 | ref 128 | (* Forward declaration, to be filled in by Typeclass.class_structure *) 129 | val type_object: 130 | (Env.t -> Location.t -> Parsetree.class_structure -> 131 | Typedtree.class_structure * Types.class_signature * string list) ref 132 | val type_package: 133 | (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> 134 | type_expr list -> Typedtree.module_expr * type_expr list) ref 135 | 136 | val create_package_type : Location.t -> Env.t -> 137 | Longident.t * (Longident.t * Parsetree.core_type) list -> 138 | Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr 139 | -------------------------------------------------------------------------------- /src/typing/PPTypemod.mli: -------------------------------------------------------------------------------- 1 | (***********************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6 | (* *) 7 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. All rights reserved. This file is distributed *) 9 | (* under the terms of the Q Public License version 1.0. *) 10 | (* *) 11 | (***********************************************************************) 12 | 13 | (* Type-checking of the module language *) 14 | 15 | open Types 16 | open Format 17 | 18 | val type_module: 19 | Env.t -> Parsetree.module_expr -> Typedtree.module_expr 20 | val type_structure: 21 | Env.t -> Parsetree.structure -> Location.t -> 22 | Typedtree.structure * Types.signature * Env.t 23 | val type_toplevel_phrase: 24 | Env.t -> Parsetree.structure -> 25 | Typedtree.structure * Types.signature * Env.t 26 | val type_implementation: 27 | string -> string -> string -> Env.t -> Parsetree.structure -> 28 | Typedtree.structure * Typedtree.module_coercion 29 | val type_interface: 30 | Env.t -> Parsetree.signature -> Typedtree.signature 31 | val transl_signature: 32 | Env.t -> Parsetree.signature -> Typedtree.signature 33 | val check_nongen_schemes: 34 | Env.t -> Typedtree.structure_item list -> unit 35 | val type_open_: 36 | ?toplevel:bool -> Asttypes.override_flag -> 37 | Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t 38 | val modtype_of_package: 39 | Env.t -> Location.t -> 40 | Path.t -> Longident.t list -> type_expr list -> module_type 41 | val simplify_signature: signature -> signature 42 | 43 | val path_of_module : Typedtree.module_expr -> Path.t option 44 | 45 | val save_signature: 46 | string -> Typedtree.signature -> string -> string -> 47 | Env.t -> Types.signature_item list -> unit 48 | 49 | val package_units: 50 | Env.t -> string list -> string -> string -> Typedtree.module_coercion 51 | 52 | type error = 53 | Cannot_apply of module_type 54 | | Not_included of Includemod.error list 55 | | Cannot_eliminate_dependency of module_type 56 | | Signature_expected 57 | | Structure_expected of module_type 58 | | With_no_component of Longident.t 59 | | With_mismatch of Longident.t * Includemod.error list 60 | | Repeated_name of string * string 61 | | Non_generalizable of type_expr 62 | | Non_generalizable_class of Ident.t * class_declaration 63 | | Non_generalizable_module of module_type 64 | | Implementation_is_required of string 65 | | Interface_not_compiled of string 66 | | Not_allowed_in_functor_body 67 | | With_need_typeconstr 68 | | Not_a_packed_module of type_expr 69 | | Incomplete_packed_module of type_expr 70 | | Scoping_pack of Longident.t * type_expr 71 | | Recursive_module_require_explicit_type 72 | | Apply_generative 73 | 74 | exception Error of Location.t * Env.t * error 75 | exception Error_forward of Location.error 76 | 77 | val report_error: Env.t -> formatter -> error -> unit 78 | -------------------------------------------------------------------------------- /test/_tags: -------------------------------------------------------------------------------- 1 | true: debug, package(alcotest typpx ppx_deriving.show str) 2 | : ppx_native 3 | : package(ppx_tools.metaquot compiler-libs.common) -------------------------------------------------------------------------------- /test/noppx.ml: -------------------------------------------------------------------------------- 1 | 2 | open Test_util 3 | open Ast_mapper 4 | open PPUtil 5 | open PPUtil.Untyped 6 | 7 | let eta_abstraction = 8 | let open PPShow in 9 | let eta_expand e = 10 | eta_abstraction_mapper.expr eta_abstraction_mapper e 11 | in 12 | let t = Pprintast.string_of_expression in 13 | List.map (fun (n, a, b) -> n, t a, t b) [ 14 | ("identifier context", 15 | eta_expand [%expr PolyPrint.string_of], 16 | [%expr fun x -> PolyPrint.string_of x]); 17 | ("application context", 18 | eta_expand [%expr PolyPrint.string_of 1], 19 | [%expr PolyPrint.string_of 1]); 20 | ("qualified, non-existent identifier", 21 | eta_expand [%expr PolyPrint.x], 22 | [%expr fun x -> PolyPrint.x x]); 23 | ("unqualified", 24 | eta_expand [%expr string_of], 25 | [%expr string_of]); 26 | ("qualified argument to qualified function", 27 | eta_expand [%expr PolyPrint.x PolyPrint.string_of], 28 | [%expr PolyPrint.x (fun x -> PolyPrint.string_of x)]); 29 | ] 30 | 31 | let app_mapper = 32 | let transform find replace e = 33 | let mapper = app_mapper find replace in 34 | mapper.expr mapper e 35 | in 36 | let t = Pprintast.string_of_expression in 37 | List.map (fun (n, a, b) -> n, t a, t b) [ 38 | ("ident", transform "a" "b" [%expr a], [%expr a]); 39 | ("app", transform "a" "b" [%expr a 1], [%expr b 1]); 40 | ("nested", transform "a" "b" [%expr fun x -> a 1], [%expr fun x -> b 1]); 41 | ("qualified", transform "a" "b" [%expr fun x -> A.a 1], [%expr fun x -> A.b 1]); 42 | ] 43 | 44 | let tests = [ 45 | test_set "eta-abstraction" eta_abstraction; 46 | test_set "app mapper" app_mapper; 47 | ] 48 | -------------------------------------------------------------------------------- /test/ppx.ml: -------------------------------------------------------------------------------- 1 | 2 | open Test_util 3 | open PolyPrint 4 | open Format 5 | 6 | type record = { a : int; b : string } 7 | (* [@@deriving show] *) 8 | 9 | (* this can be removed when the typpx-deriving bug is fixed *) 10 | let pp_record fmt { a; b } = 11 | fprintf fmt "{ a = %d; b = %s }" a b 12 | 13 | class some_class = 14 | object (self) 15 | val field = 1 16 | method meth x = 17 | x + 1 18 | method meth2 = 19 | field 20 | method to_string = 21 | "this is some class" 22 | end 23 | 24 | (* this needs to be defined *) 25 | let pp_some_class fmt sc = 26 | fprintf fmt "%s" sc#to_string 27 | 28 | let singleton_obj = object 29 | val v = 1 30 | method meth = v 31 | end 32 | 33 | let simple = [ 34 | "int", to_string 1, "1"; 35 | "bool", to_string false, "false"; 36 | "string", to_string "something", "something"; 37 | "char", to_string 'a', "a"; 38 | "float", to_string 1.2, "1.2"; 39 | "tuple", to_string (1, 2), "(1, 2)"; 40 | "tuple3", to_string (1, 2, 3), "(1, 2, 3)"; 41 | "tuple4", to_string (1, 2, 3, 4), "(1, 2, 3, 4)"; 42 | "tuple5", to_string (1, 2, 3, 4, 5), "(1, 2, 3, 4, 5)"; 43 | "tuple6", to_string (1, 2, 3, 4, 5, 6), "(1, 2, 3, 4, 5, 6)"; 44 | "tuple7", to_string (1, 2, 3, 4, 5, 6, 7), "(1, 2, 3, 4, 5, 6, 7)"; 45 | "int list", to_string [1; 2], "[1; 2]"; 46 | "bool list", to_string [true; false], "[true; false]"; 47 | "ref", to_string (ref 1), "ref 1"; 48 | "object (of class)", to_string (new some_class), "this is some class"; 49 | "object (singleton)", (to_string singleton_obj), "< meth : int >"; 50 | "exn", to_string (Failure "what"), "Failure(\"what\")"; 51 | "record", to_string { a = 1; b = "hi" }, "{ a = 1; b = hi }"; 52 | "int32", to_string (Int32.of_int 45), "45"; 53 | "int64", to_string (Int64.of_int 74), "74"; 54 | "nativeint", to_string (Nativeint.of_int 65), "65"; 55 | "unit", to_string (), "()"; 56 | ] 57 | 58 | let functions = [ 59 | "function literal", show (fun x -> x), " x : 'a -> 'a>"; 60 | "function variable", (let y x = x in show y), " 'a>"; 61 | ] 62 | 63 | type ('a, 'b) either = Left of 'a | Right of 'b 64 | [@@deriving show] 65 | 66 | let compound = [ 67 | "int tuple list", to_string [(1, 2)], "[(1, 2)]"; 68 | "nested tuples", to_string (1, (2, (3, 4))), "(1, (2, (3, 4)))"; 69 | "heterogeous tuples", to_string (1, "klasjd", true), "(1, klasjd, true)"; 70 | "option none", to_string None, "None"; 71 | "option int", to_string (Some 1), "Some 1"; 72 | "option string", to_string (Some "two"), "Some two"; 73 | "user-defined either 1 (defaults to show_either)", to_string (Left 1), "(Ppx.Left 1)"; 74 | "user-defined either 2", to_string (Right "hello"), "(Ppx.Right hello)"; 75 | ] 76 | 77 | module Something : sig 78 | type t 79 | val thing : t 80 | val pp_t : Format.formatter -> t -> unit 81 | 82 | val id : t -> t 83 | 84 | type 'a s = Cons of 'a * 'a s | Nil 85 | 86 | val pp_s : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a s -> unit 87 | end = 88 | struct 89 | type t = int 90 | 91 | (* if we derive show, we can't constrain the module via its signature 92 | as the printers will be absent. *) 93 | (* [@@deriving show] *) 94 | 95 | let pp_t = pp_print_int 96 | 97 | let thing = 1 98 | 99 | type 'a s = Cons of 'a * 'a s | Nil 100 | [@@deriving show] 101 | 102 | let id x = x 103 | 104 | let rec pp_s pp fmt xs = 105 | let rec aux xs = 106 | match xs with 107 | | Nil -> fprintf fmt "" 108 | | Cons (x, Nil) -> fprintf fmt "%a" pp x 109 | | Cons (y, ys) -> fprintf fmt "%a; " pp y; aux ys 110 | in 111 | fprintf fmt "["; 112 | aux xs; 113 | fprintf fmt "]" 114 | end 115 | 116 | let qualified = [ 117 | "qualified abstract value", to_string Something.id, " Something.t>"; 118 | "qualified abstract value t defaults to show_t", to_string Something.thing, "1"; 119 | "qualified parameterised abstract value", Something.(to_string (Cons (1, Cons (2, Nil)))), "[1; 2]"; 120 | "qualified parameterised abstract value", Something.(to_string (Cons ("a", Cons ("b", Nil)))), "[a; b]"; 121 | ] 122 | 123 | let type_variables = 124 | let string_form_of x = to_string x in 125 | let wrap_and_stringify x = to_string (Some x) in [ 126 | "polymorphic to_string 1", string_form_of 1, ""; 127 | "polymorphic to_string 2", string_form_of (None), ""; 128 | "polymorphic to_string 3", to_string (wrap_and_stringify 1), "Some "; 129 | "polymorphic to_string 4", to_string (wrap_and_stringify None), "Some "; 130 | ] 131 | 132 | let higher_order = 133 | let showp pr a = pr a in [ 134 | "intended transformation", showp (fun x -> to_string x) 1, "1"; 135 | "int", showp PolyPrint.to_string 1, "1"; 136 | "string", showp PolyPrint.to_string "aaa", "aaa"; 137 | "aliases 1", showp PolyPrint.string_of "aaa", "aaa"; 138 | "aliases 2", showp PolyPrint.show "aaa", "aaa"; 139 | (* only qualified names are eta abstracted *) 140 | "unqualified", showp to_string 1, "'_a"; 141 | (* no support for this currently *) 142 | "constrained", showp (to_string : int -> string) 1, "'_a"; 143 | ] 144 | 145 | module TestConfig = struct 146 | 147 | let count = ref 0 148 | let last = ref 0 149 | 150 | let called = ref false 151 | let two_called = ref false 152 | 153 | let reset () = 154 | count := 0; 155 | last := 0; 156 | called := false; 157 | two_called := false 158 | 159 | class api = object (self) 160 | inherit DefaultTraceConfig.api 161 | 162 | method run1 fn_name (a_n, pr_a, a) pr_res f = 163 | incr count; last := 1; f a 164 | 165 | method run2 fn_name (a_n, pr_a, a) (b_n, pr_b, b) pr_res f = 166 | incr count; last := 2; f a b 167 | 168 | method call1 _ f a = 169 | called := true; f a 170 | 171 | method call2 _ f a b = 172 | two_called := true; f a b 173 | end 174 | 175 | let act = new api 176 | end 177 | 178 | module Otherwise = struct 179 | module Default = struct 180 | 181 | let called = ref false 182 | 183 | let reset () = 184 | called := false 185 | 186 | class api = object (self) 187 | inherit DefaultTraceConfig.api 188 | 189 | method call1 _ f a = 190 | called := true; f a 191 | end 192 | 193 | let act = new api 194 | end 195 | end 196 | 197 | let rec fact_str n = 198 | if n = 0 then 1 else n * fact_str (n - 1) 199 | [@@trace TestConfig] 200 | 201 | let plus_str a b = a + b 202 | [@@trace TestConfig] 203 | 204 | let rec fact_str_rec n = 205 | if n = 0 then 1 else n * fact_str_rec (n - 1) 206 | [@@tracerec TestConfig] 207 | 208 | (* These should fail, but can't really be tested... *) 209 | 210 | (* let plus_str_rec a b = a + b *) 211 | (* [@@tracerec TestConfig] *) 212 | 213 | (* let [@tracerec TestConfig] plus_expr_rec a b = a + b in () *) 214 | 215 | (* This is a copy of the existing unary wrapper type *) 216 | (* type ('a, 'b) traced1 = Traced1 of ('a -> 'b) *) 217 | 218 | (* This should fail with a type error only if the above line is not commented out *) 219 | (* let id = Traced1 (fun x -> x) in id 2 *) 220 | 221 | (* Has to be here for now, or the test fails *) 222 | [@@@polyprint Otherwise.Default] 223 | 224 | let tracing = 225 | let [@trace TestConfig] rec fact_expr n = 226 | if n = 0 then 1 else n * fact_expr (n - 1) 227 | in 228 | let [@trace TestConfig] plus_expr a b = a + b in 229 | let [@tracerec TestConfig] rec fact_expr_rec n = 230 | if n = 0 then 1 else n * fact_expr_rec (n - 1) 231 | in 232 | let open TestConfig in [ 233 | ("recursive trace expression", 234 | begin 235 | reset (); 236 | ignore (fact_expr 5); 237 | !count = 1 238 | end); 239 | 240 | ("recursive trace structure", 241 | begin 242 | reset (); 243 | ignore (fact_str 5); 244 | !count = 1 245 | end); 246 | 247 | ("recursive tracerec expression", 248 | begin 249 | reset (); 250 | ignore (fact_expr_rec 5); 251 | !count = 6 252 | end); 253 | 254 | ("recursive tracerec structure", 255 | begin 256 | reset (); 257 | ignore (fact_str_rec 5); 258 | !count = 6 259 | end); 260 | 261 | ("non-recursive trace expression", 262 | begin 263 | reset (); 264 | ignore (plus_expr 2 3); 265 | !count = 1 266 | end); 267 | 268 | ("non-recursive trace structure", 269 | begin 270 | reset (); 271 | ignore (plus_str 2 3); 272 | !count = 1 273 | end); 274 | 275 | ("non-recursive trace structure", 276 | begin 277 | reset (); 278 | ignore (plus_str 2 3); 279 | !count = 1 280 | end); 281 | 282 | ("variable filtering", 283 | let [@tracerec TestConfig; a] rec var_filtering1 a b c d = 284 | if a = 4 then 5 285 | else var_filtering1 b c d a 286 | in 287 | let [@tracerec TestConfig; a, b] rec var_filtering2 a b c d = 288 | if a = 4 then 5 289 | else var_filtering2 b c d a 290 | in 291 | reset (); 292 | let a = !last = 0 in 293 | ignore (var_filtering1 1 2 3 4); 294 | let b = !last = 1 in 295 | ignore (var_filtering2 1 2 3 4); 296 | let c = !last = 2 in 297 | a && b && c); 298 | 299 | ("default annotation", 300 | let [@trace] id x = x in 301 | Otherwise.Default.reset (); 302 | let a = not !Otherwise.Default.called in 303 | ignore @@ id 1; 304 | let b = !Otherwise.Default.called in 305 | a && b); 306 | 307 | ("call wrapping basic", 308 | let [@trace TestConfig] rather_unique x = x in 309 | reset (); 310 | let a = not !called in 311 | ignore @@ rather_unique 1 [@polyprint TestConfig]; 312 | let b = !called in 313 | a && b); 314 | 315 | ("call wrapping partial application", 316 | let [@trace TestConfig] binary_fn x y = x + y in 317 | reset (); 318 | let a = not !two_called in 319 | let partial = binary_fn 1 [@polyprint TestConfig] in 320 | let b = not !two_called && not !called in 321 | ignore @@ partial 2; 322 | (* call2 is invoked here, only when application is fully *) 323 | (* saturated, and with the saturated arity *) 324 | let c = !two_called && not !called in 325 | a && b && c); 326 | ] 327 | 328 | let tests = [ 329 | test_set "simple" simple; 330 | test_set "functions" functions; 331 | test_set "compound" compound; 332 | test_set "qualified" qualified; 333 | test_set "type variables" type_variables; 334 | test_set "higher-order" higher_order; 335 | basic_test_set "tracing" tracing; 336 | ] 337 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | 2 | let () = 3 | Alcotest.run "ppx_polyprint" @@ List.concat [ 4 | Noppx.tests; 5 | Ppx.tests; 6 | ]; 7 | 8 | -------------------------------------------------------------------------------- /test/test_util.ml: -------------------------------------------------------------------------------- 1 | 2 | let test_case name expected actual = 3 | name, `Quick, fun () -> Alcotest.(check string) name expected actual 4 | 5 | let basic_test_case name actual = 6 | name, `Quick, fun () -> Alcotest.(check bool) name true actual 7 | 8 | let uncurry2 f (a, b) = f a b 9 | 10 | let uncurry3 f (a, b, c) = f a b c 11 | 12 | let test_set name tests = 13 | (name, List.map (uncurry3 test_case) tests) 14 | 15 | let basic_test_set name tests = 16 | (name, List.map (uncurry2 basic_test_case) tests) 17 | --------------------------------------------------------------------------------