├── .gitignore ├── CHANGES.md ├── LICENSE ├── Makefile ├── README.md ├── cmon.opam ├── dune-project ├── lib ├── Makefile ├── cmon.ml ├── cmon.mli └── dune └── tests ├── Makefile ├── dune ├── test.expected └── test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v0.2 Fri Apr 1 16:30:01 JST 2022 2 | --------------------------------- 3 | 4 | Bug fix in introduction of nested non-recursive let bindings. 5 | 6 | v0.1 Tue Jan 18 09:29:12 CET 2022 7 | --------------------------------- 8 | 9 | First release. 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Frédéric Bour 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. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | test: 2 | dune runtest 3 | 4 | all: 5 | dune build 6 | 7 | clean: 8 | dune clean 9 | 10 | promote: 11 | dune promote 12 | 13 | build-install: 14 | dune build @install 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CMON : CaMl Object Notation 2 | 3 | `Cmon` provides a few tools for printing values. This "object notation" mimics the syntax of OCaml literal values: tuples, named constructors and records. 4 | 5 | No parser is provided (yet?). The library is intended to print values, for logging and debugging, that can be copy-pasted to an OCaml toplevel. 6 | 7 | The unusual feature is that the printer makes sharing explicit: let-binding are introduced at the optimal place by computing dominating nodes. This is particularly convenient for printing the internal structures of symbolic manipulation tools (e.g. typecheckers) that can internally make use of sharing a lot. 8 | 9 | ## Example 10 | 11 | A few samples, from the toplevel: 12 | 13 | ```ocaml 14 | # #require "cmon";; 15 | # #install_printer Cmon.format;; 16 | # Cmon.unit 17 | - : Cmon.t = () 18 | # Cmon.record ["int", Cmon.int 42; "bool", Cmon.bool false];; 19 | - : Cmon.t = { int = 42; bool = false; } 20 | # let ty1 = Cmon.construct "Ty_arrow" [ 21 | Cmon.construct "Ty_int" []; 22 | Cmon.construct "Ty_int" [] 23 | ];; 24 | val ty1 : Cmon.t = Ty_arrow (Ty_int, Ty_int) 25 | # (* Printing the type derivation for a fictitious, simple, 26 | programming language to illustrate sharing of sub values *) 27 | Cmon.crecord "Let_binding" [ 28 | "name", Cmon.string "id_int"; 29 | "typ", ty1; 30 | "body", Cmon.crecord "Exp_fun" [ 31 | "var", Cmon.string "x"; 32 | "typ", ty1; 33 | "body", Cmon.construct "Exp_ident" [Cmon.string "x"] 34 | ] 35 | ];; 36 | - : Cmon.t = 37 | let v0 = Ty_arrow (Ty_int, Ty_int) in 38 | Let_binding { 39 | name = "id_int"; 40 | typ = v0; 41 | body = Exp_fun { var = "x"; typ = v0; body = Exp_ident "x"; }; 42 | } 43 | ``` 44 | 45 | ## Installation and usage 46 | 47 | The library is distributed on opam: 48 | 49 | ```shell 50 | $ opam install cmon 51 | ``` 52 | 53 | Add `cmon` in the `libraries` of a `dune` file to use it. 54 | 55 | ## Documentation 56 | 57 | Simple values are built using the functions `unit`, `bool`, `char`, `int`, `float`, `string`, `tuple`, `record`, `nil`, `cons`, `list`, `constant`, `construct` and `crecord`. 58 | 59 | ```ocaml 60 | # #require "cmon";; 61 | # #install_printer Cmon.format;; 62 | # open Cmon;; 63 | # unit;; 64 | - : t = () 65 | # bool false;; 66 | - : t = false 67 | # int 10;; 68 | - : t = 10 69 | # char 'a';; 70 | - : t = 'a' 71 | # float 10.0;; 72 | - : t = 10. 73 | # string "foo";; 74 | - : t = "foo" 75 | # tuple [int 42; bool true];; 76 | - : t = (42, true) 77 | # record ["field1", int 1; "field2", char 'b'];; 78 | - : t = { field1 = 1; field2 = 'b'; } 79 | # nil;; 80 | - : t = [] 81 | # cons (int 1) nil;; 82 | - : t = [ 1 ] 83 | # cons (int 1) (constant "x");; 84 | - : t = 1 :: x 85 | # cons (int 1) (constant "xs");; 86 | - : t = 1 :: xs 87 | # list [int 1; int 2; int 3];; 88 | - : t = [ 1; 2; 3 ] 89 | # crecord "Inline_record" ["field1", int 1; "field2", char 'b'];; 90 | - : t = Inline_record { field1 = 1; field2 = 'b'; } 91 | ``` 92 | 93 | Sharing is enabled by default for all compound values and strings. 94 | 95 | ```ocaml 96 | # let twice x = Cmon.tuple [x;x];; 97 | # twice (string "foo-bar-baz");; 98 | - : t = let v0 = "foo-bar-baz" in 99 | (v0, v0) 100 | # twice (construct "None" []);; 101 | - : t = (None, None) 102 | # twice (construct "Some" [bool true]);; 103 | - : t = let v0 = Some true in 104 | (v0, v0) 105 | ``` 106 | 107 | To opt out, use the `unshared_*` variants of the main functions to opt out: `unshared_construct`, `unshared_crecord`, `unshared_list`, `unshared_record`, `unshared_string`, `unshared_tuple`. 108 | 109 | ```ocaml 110 | # twice (unshared_string "foo-bar-baz");; 111 | - : t = ("foo-bar-baz", "foo-bar-baz") 112 | # twice (unshared_construct "Some" [bool true]);; 113 | - : t = (Some true, Some true) 114 | ``` 115 | 116 | Sharing is based on the physical identities of `Cmon.t` values, not their structure: 117 | 118 | ```ocaml 119 | # let s = string "foo-bar-baz" in 120 | Cmon.tuple [s; s];; 121 | - : t = let v0 = "foo-bar-baz" in 122 | (v0, v0) 123 | # Cmon.tuple [string "foo-bar-baz"; string "foo-bar-baz"];; 124 | - : t = ("foo-bar-baz", "foo-bar-baz") 125 | ``` 126 | 127 | Once composed, a `Cmon.t` value can be converted to a [`PPrint.document`](https://github.com/fpottier/pprint) or directly sent to a `Format.formatter`: 128 | 129 | ```ocaml 130 | val Cmon.print : t -> PPrint.document 131 | val Cmon.format : Format.formatter -> t -> unit 132 | ``` 133 | 134 | ## Inspecting `Cmon.t` values 135 | 136 | `Cmon.t` is defined as an algebraic type: 137 | 138 | ```ocaml 139 | type t = 140 | | Unit (* () *) 141 | | Nil (* [] *) 142 | | Bool of bool (* true, false *) 143 | | Char of char (* 'x' *) 144 | | Int of int (* 0, 1, ... *) 145 | | Int32 of int32 (* 0l, 1l, ... *) 146 | | Int64 of int64 (* 0L, 1L, ... *) 147 | | Nativeint of nativeint (* 0n, 1n, ... *) 148 | | Float of float (* 0.0, 1.0, ... *) 149 | | Constant of string (* constant constructor, e.g None *) 150 | | Cons of {id: id; car: t; cdr: t} (* x :: xs *) 151 | | String of {id: id; data: string} (* "Foo" *) 152 | | Tuple of {id: id; data: t list} (* (a, b, c) ... *) 153 | | Record of {id: id; data: (string * t) list} (* {a: va; b: vb} *) 154 | | Constructor of {id: id; tag: string; data: t} (* Some foo *) 155 | | Array of {id: id; data: t array} 156 | | Lazy of {id: id; data: t lazy_t} 157 | | Var of id (* x *) 158 | | Let of {id: id; recursive: bool; bindings: (var * t) list; body: t} 159 | ``` 160 | 161 | It is possible to match on `Cmon.t` values, inspect their structure, and create 162 | new values. This is useful for debugging and understanding how Cmon works but 163 | not recommended in normal use (one could easily create "unbound" variables by 164 | messing with the structure). Stick to the public functions. 165 | 166 | The `Cmon.explicit_sharing` function can reveal the sharing that would be 167 | displayed by the `print` functions: 168 | 169 | ```ocaml 170 | # let c = Cmon.tuple [s; s];; 171 | val c : t = 172 | Tuple 173 | {Cmon.id = 6; 174 | data = 175 | [String {Cmon.id = 4; data = "foo-bar-baz"}; 176 | String {Cmon.id = 4; data = "foo-bar-baz"}]} 177 | # Cmon.explicit_sharing c;; 178 | - : t = 179 | Let 180 | {Cmon.id = 5; bindings = [(0, String {Cmon.id = 1; data = "foo-bar-baz"})]; 181 | body = Tuple {Cmon.id = 0; data = [Var 0; Var 0]}} 182 | ``` 183 | 184 | Printing is done either with the `print` or `format` functions: 185 | 186 | ```ocaml 187 | val Cmon.print : t -> PPrint.document 188 | val Cmon.format : Format.formatter -> t -> unit 189 | ``` 190 | 191 | To print without introducing more sharing, the `_as_is` variants are provided: 192 | 193 | ```ocaml 194 | val Cmon.print_as_is : t -> PPrint.document 195 | val Cmon.format_as_is : Format.formatter -> t -> unit 196 | ``` 197 | 198 | Mixing `explicit_sharing` and `print_as_is` can be useful to print composite 199 | documents while "controlling" sharing boundaries. 200 | 201 | ## 202 | -------------------------------------------------------------------------------- /cmon.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "A library for printing OCaml values with sharing" 4 | maintainer: ["frederic.bour@lakaban.net"] 5 | authors: ["Frédéric Bour"] 6 | license: "MIT" 7 | homepage: "https://github.com/let-def/cmon" 8 | bug-reports: "https://github.com/let-def/cmon/issues" 9 | depends: [ 10 | "dune" {>= "2.9"} 11 | "pprint" {>= "20171003"} 12 | "grenier" {>= "0.14"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "--promote-install-files=false" 25 | "@install" 26 | "@runtest" {with-test} 27 | "@doc" {with-doc} 28 | ] 29 | ["dune" "install" "-p" name "--create-install-files" name] 30 | ] 31 | dev-repo: "git+https://github.com/let-def/cmon.git" 32 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | (name cmon) 3 | (generate_opam_files true) 4 | 5 | (source (github let-def/cmon)) 6 | (license MIT) 7 | (authors "Frédéric Bour") 8 | (maintainers "frederic.bour@lakaban.net") 9 | 10 | (package 11 | (name cmon) 12 | (synopsis "A library for printing OCaml values with sharing") 13 | (depends (pprint (>= 20171003)) 14 | (grenier (>= 0.14)))) 15 | -------------------------------------------------------------------------------- /lib/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build 3 | 4 | clean: 5 | dune clean 6 | -------------------------------------------------------------------------------- /lib/cmon.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2021 Frédéric Bour 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (* Basic cmon definitions *) 18 | 19 | type id = int 20 | let id_k = ref 0 21 | let id = fun () -> incr id_k; !id_k 22 | let unshared = 0 23 | 24 | type var = id 25 | 26 | type t = 27 | | Unit 28 | | Nil 29 | | Bool of bool 30 | | Char of char 31 | | Int of int 32 | | Int32 of int32 33 | | Int64 of int64 34 | | Nativeint of nativeint 35 | | Float of float 36 | | Constant of string 37 | | Cons of {id: id; car: t; cdr: t} 38 | | String of {id: id; data: string} 39 | | Tuple of {id: id; data: t list} 40 | | Record of {id: id; data: (string * t) list} 41 | | Constructor of {id: id; tag: string; data: t} 42 | | Array of {id: id; data: t array} 43 | | Lazy of {id: id; data: t lazy_t} 44 | | Var of var 45 | | Let of {id: id; recursive: bool; bindings: (var * t) list; body: t} 46 | 47 | let nil = Nil 48 | let unit = Unit 49 | let bool data = Bool data 50 | let char data = Char data 51 | let int data = Int data 52 | let int32 data = Int32 data 53 | let int64 data = Int64 data 54 | let nativeint data = Nativeint data 55 | let float data = Float data 56 | let string data = String {id=id(); data} 57 | let constant tag = Constant tag 58 | let constructor tag data = Constructor {id=id(); tag; data} 59 | let tuple data = Tuple {id=id(); data} 60 | let record data = Record {id=id(); data} 61 | let cons car cdr = Cons {id=id(); car; cdr} 62 | 63 | let unshared_string data = String{id=unshared; data} 64 | let unshared_constructor tag data = Constructor {id=unshared; tag; data} 65 | let unshared_tuple data = Tuple {id=unshared; data} 66 | let unshared_record data = Record {id=unshared; data} 67 | let unshared_cons car cdr = Cons {id=unshared; car; cdr} 68 | 69 | let list xs = List.fold_right cons xs nil 70 | let list_map f xs = list (List.map f xs) 71 | let unshared_list xs = List.fold_right unshared_cons xs nil 72 | 73 | let array data = Array{id=id(); data} 74 | let array_map f xs = array (Array.map f xs) 75 | let unshared_array data = Array {id=unshared; data} 76 | 77 | let construct tag = function 78 | | [] -> constant tag 79 | | [x] -> constructor tag x 80 | | xs -> constructor tag (unshared_tuple xs) 81 | 82 | let unshared_construct tag = function 83 | | [] -> constant tag 84 | | [x] -> unshared_constructor tag x 85 | | xs -> unshared_constructor tag (unshared_tuple xs) 86 | 87 | let crecord tag data = constructor tag (unshared_record data) 88 | let unshared_crecord tag data = unshared_constructor tag (unshared_record data) 89 | 90 | (* Graph traversal and sharing *) 91 | 92 | let id_of = function 93 | | Bool _ | Char _ | Int _ | Int32 _ | Int64 _ | Nativeint _ 94 | | Float _ | Nil | Unit | Constant _ | Var _ -> unshared 95 | | Tuple {id; _} | Record {id; _} | Constructor {id; _} | Cons {id; _} 96 | | String {id; _} | Let {id; _} | Array {id; _} | Lazy {id; _} -> id 97 | 98 | let graph : t Fastdom.graph = { 99 | successors = begin fun f acc -> 100 | let rec aux acc = function 101 | | Bool _ | Char _ | Int _ | Int32 _ | Int64 _ | Nativeint _ 102 | | Float _ | Nil | Unit | Constant _ 103 | | String _ | Var _ | Let _ -> acc 104 | | Lazy {data = lazy t; _} -> f_ acc t 105 | | Tuple {data; _} -> List.fold_left f_ acc data 106 | | Record {data; _} -> List.fold_left f_field acc data 107 | | Array {data; _} -> Array.fold_left f_ acc data 108 | | Constructor {data; _} -> f_ acc data 109 | | Cons {car; cdr; _} -> f_ (f_ acc car) cdr 110 | and f_field acc (_, v) = 111 | f_ acc v 112 | and f_ acc self = 113 | if id_of self <> unshared 114 | then f acc self 115 | else aux acc self 116 | in 117 | aux acc 118 | end; 119 | memoize = begin fun (type b) (f : _ -> b) -> 120 | let table : (id, b) Hashtbl.t = Hashtbl.create 7 in 121 | fun x -> 122 | let id = id_of x in 123 | if id = unshared then f x else 124 | try Hashtbl.find table id 125 | with Not_found -> 126 | let y = f x in 127 | Hashtbl.add table id y; 128 | y 129 | end; 130 | } 131 | 132 | let binding_structure : (t, int) Binder_introducer.binding_structure = { 133 | name_term = (fun _ -> id ()); 134 | var_term = (fun id -> Var id); 135 | map_subterms = begin fun f t -> 136 | let rec sub_map = function 137 | | Bool _ | Char _ | Int _ | Int32 _ | Int64 _ | Nativeint _ 138 | | Float _ | Nil | Unit | Constant _ 139 | | String _ | Var _ | Let _ as t -> t 140 | | Lazy {data = lazy t; _} -> f' t 141 | | Tuple t -> 142 | unshared_tuple (List.map f' t.data) 143 | | Record t -> 144 | unshared_record (List.map (fun (k,v) -> k, f' v) t.data) 145 | | Constructor t -> 146 | unshared_constructor t.tag (f' t.data) 147 | | Cons t -> 148 | unshared_cons (f' t.car) (f' t.cdr) 149 | | Array t -> 150 | unshared_array (Array.map f' t.data) 151 | and f' t = 152 | if id_of t = unshared then 153 | sub_map t 154 | else 155 | f t 156 | in 157 | sub_map t 158 | end; 159 | introduce_let = begin fun ~recursive bindings body -> 160 | Let {id=id(); recursive; bindings; body} 161 | end; 162 | } 163 | 164 | let explicit_sharing t = 165 | Binder_introducer.explicit_sharing graph binding_structure t 166 | 167 | (* Pretty-printing *) 168 | 169 | let rec list_of_cons acc = function 170 | | Cons {id = _; car; cdr} -> list_of_cons (car :: acc) cdr 171 | | Nil -> List.rev acc, None 172 | | other -> List.rev acc, Some other 173 | 174 | let print_record f fields = 175 | let add_field acc x = 176 | let k, v = f x in 177 | PPrint.(acc ^/^ group (group(string k ^/^ char '=') ^^ 178 | nest 2 (break 1 ^^ v) ^^ char ';')) 179 | in 180 | let fields = List.fold_left add_field PPrint.empty fields in 181 | PPrint.(group (string "{" ^^ nest 2 fields ^/^ string "}")) 182 | 183 | let print_as_is var_name doc = 184 | let open PPrint in 185 | let rec sub_print_as_is = function 186 | | Unit -> true, string "()" 187 | | Nil -> true, string "[]" 188 | | Constant tag -> true, string tag 189 | | Bool b -> true, OCaml.bool b 190 | | Char c -> true, OCaml.char c 191 | | Int i -> true, OCaml.int i 192 | | Int32 i -> true, OCaml.int32 i 193 | | Int64 i -> true, OCaml.int64 i 194 | | Nativeint i -> true, OCaml.nativeint i 195 | | Float f -> true, OCaml.float f 196 | | Lazy {id=_; data=lazy t} as t' -> 197 | if t == t' 198 | then (true, string "") 199 | else sub_print_as_is t 200 | | Cons _ as self -> 201 | begin match list_of_cons [] self with 202 | | items, None -> 203 | true, OCaml.list print_as_is items 204 | | items, Some cdr -> 205 | false, 206 | group ( 207 | let print_one item = 208 | group (string "::" ^/^ item) 209 | in 210 | let rec print = function 211 | | [] -> print_one (print_as_is cdr) 212 | | x :: xs -> print_one (print_as_is x) ^^ break 1 ^^ print xs 213 | in 214 | match items with 215 | | x :: xs -> print_as_is x ^^ break 1 ^^ print xs 216 | | [] -> assert false 217 | ) 218 | end 219 | | Array {id=_; data} -> true, OCaml.array print_as_is data 220 | | String {id=_; data} -> true, OCaml.string data 221 | | Tuple {id=_; data} -> 222 | true, OCaml.tuple (List.map print_as_is data) 223 | | Record {id=_; data} -> 224 | true, 225 | (*OCaml.record "" (List.map (fun (k,v) -> k, print_as_is v) data)*) 226 | print_record (fun (k,v) -> k, print_as_is v) data 227 | | Constructor {id=_; tag; data} -> 228 | let delimited, sub_doc = sub_print_as_is data in 229 | let doc = 230 | if delimited 231 | then sub_doc 232 | else OCaml.tuple [sub_doc] 233 | in 234 | false, group (string tag ^^ blank 1 ^^ doc) 235 | | Var id -> true, string (var_name id) 236 | | Let {id=_; recursive; bindings; body} -> 237 | let rec print_bindings prefix = function 238 | | [] -> string "in" 239 | | (id, value) :: values -> 240 | let doc = print_as_is value in 241 | let need_break = match value with Let _ -> true | _ -> false in 242 | let doc = 243 | group @@ 244 | if need_break 245 | then group (string prefix ^/^ id ^/^ string "=") ^^ 246 | nest 2 (break 1 ^^ doc) 247 | else group (string prefix ^/^ id ^/^ string "= ") ^^ 248 | nest 2 doc 249 | in 250 | doc ^/^ print_bindings "and" values 251 | in 252 | let name_binding (id, value) = (string (var_name id), value) in 253 | let prefix = if recursive then "let rec" else "let" in 254 | let bindings = List.map name_binding bindings in 255 | let bindings = group (print_bindings prefix bindings) in 256 | false, 257 | bindings ^/^ 258 | print_as_is body 259 | and print_as_is doc = 260 | let _delim, doc = sub_print_as_is doc in 261 | doc 262 | in 263 | print_as_is doc 264 | 265 | let print_as_is doc = 266 | let table = Hashtbl.create 7 in 267 | let var_name id = 268 | match Hashtbl.find_opt table id with 269 | | Some name -> name 270 | | None -> 271 | let name = "v" ^ string_of_int (Hashtbl.length table) in 272 | Hashtbl.replace table id name; 273 | name 274 | in 275 | print_as_is var_name doc 276 | 277 | let format_document ppf doc : unit = 278 | let margin = Format.pp_get_margin ppf () in 279 | Format.fprintf ppf "@[%a@]" (PPrint.ToFormatter.pretty 0.9 margin) doc 280 | 281 | let format_as_is ppf t : unit = 282 | format_document ppf (print_as_is t) 283 | 284 | let print t : PPrint.document = print_as_is (explicit_sharing t) 285 | let format ppf t : unit = format_as_is ppf (explicit_sharing t) 286 | 287 | let of_lazy data = Lazy {id=id(); data} 288 | -------------------------------------------------------------------------------- /lib/cmon.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2021 Frédéric Bour 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** 18 | "Caml Object Notation", a library for pretty-printing ocaml values 19 | with sharing. 20 | *) 21 | 22 | type id = private int 23 | (** Unique identifiers to make sharing explicit. 24 | Variable names are automatically generated. 25 | *) 26 | 27 | type var = id 28 | 29 | (** The output is the syntax of OCaml values (with unique identifiers 30 | for structured values) extended with variables and let-bindings 31 | to represent sharing. 32 | *) 33 | type t = 34 | | Unit (* () *) 35 | | Nil (* [] *) 36 | | Bool of bool (* true, false *) 37 | | Char of char (* 'x' *) 38 | | Int of int (* 0, 1, ... *) 39 | | Int32 of int32 (* 0l, 1l, ... *) 40 | | Int64 of int64 (* 0L, 1L, ... *) 41 | | Nativeint of nativeint (* 0n, 1n, ... *) 42 | | Float of float (* 0.0, 1.0, ... *) 43 | | Constant of string (* constant constructor, e.g None *) 44 | | Cons of {id: id; car: t; cdr: t} (* x :: xs *) 45 | | String of {id: id; data: string} (* "Foo" *) 46 | | Tuple of {id: id; data: t list} (* (a, b, c) ... *) 47 | | Record of {id: id; data: (string * t) list} (* {a: va; b: vb} *) 48 | | Constructor of {id: id; tag: string; data: t} (* Some foo *) 49 | | Array of {id: id; data: t array} 50 | | Lazy of {id: id; data: t lazy_t} 51 | | Var of id (* x *) 52 | | Let of {id: id; recursive: bool; bindings: (var * t) list; body: t} 53 | 54 | (** Primitive values *) 55 | 56 | val unit: t 57 | (** print `()` *) 58 | 59 | val bool: bool -> t 60 | (** print `true` or `false` *) 61 | 62 | val char: char -> t 63 | (** print a single quoted character, escaped if necessary *) 64 | 65 | val int: int -> t 66 | (** print an integer *) 67 | 68 | val int32: int32 -> t 69 | (** print a 32-bit integer *) 70 | 71 | val int64: int64 -> t 72 | (** print a 64-bit integer *) 73 | 74 | val nativeint: nativeint -> t 75 | (** print a native integer *) 76 | 77 | val float: float -> t 78 | (** print a floating point value *) 79 | 80 | val string: string -> t 81 | (** print a double quoted string, with necessary escapes *) 82 | 83 | val constant: string -> t 84 | (** print a literal string (without quoting), useful for non-parameterized 85 | data constructors. [constant "None"] prints `None`. *) 86 | 87 | val constructor: string -> t -> t 88 | (** print a parameterized dataconstructor. 89 | [constructor "Some" unit] prints `Some ()`. *) 90 | 91 | val tuple: t list -> t 92 | (** print an OCaml tuple. 93 | [tuple [int 1; char 'c']] prints `(1, 'c')`. *) 94 | 95 | val record: (string * t) list -> t 96 | (** print an OCaml record. 97 | [record ["a", int 1; "b", bool false]] prints `{a: 1, b: false}`. *) 98 | 99 | val cons: t -> t -> t 100 | (** construct a cons cell. 101 | [cons (int 1) nil] prints `[1]`, 102 | [cons (int 1) (constant "xs")] prints `1 :: xs`, *) 103 | 104 | val construct: string -> t list -> t 105 | (** Shortcut for a data constructor with multiple arguments. 106 | [construct "None" []] = [constant "None"] prints `None`, 107 | [construct "Some" [int 1]] = [constructor "Some" (int 1)] prints `Some 1`, 108 | [construct "A" [int 1; int 2] = [constructor "A" (tuple [int 1; int 2])] 109 | prints `A (1, 2)`. 110 | *) 111 | 112 | val crecord: string -> (string * t) list -> t 113 | (** Shortcut for constructor with inline record. 114 | [crecord "A" ["a", int 1; "b", bool false]] prints `A {a: 1, b: false}`. *) 115 | 116 | val nil: t 117 | (** nil prints `[]` *) 118 | 119 | val list: t list -> t 120 | (** [list xs] = [List.fold_right cons xs nil]. 121 | [list [int 1; int 2; int 3]] prints `[1; 2; 3]`. *) 122 | 123 | val list_map: ('a -> t) -> 'a list -> t 124 | (** [list_map f xs] = [list (List.map f xs)] *) 125 | 126 | val array: t array -> t 127 | (** [array [|int 1; int 2; int 3|]] prints `[| 1; 2; 3 |]`. *) 128 | 129 | val array_map: ('a -> t) -> 'a array -> t 130 | (** [array_map f xs] = [array (Array.map f xs)] *) 131 | 132 | (** Variants that prevent sharing these values *) 133 | 134 | val unshared_string: string -> t 135 | val unshared_constructor: string -> t -> t 136 | val unshared_tuple: t list -> t 137 | val unshared_record: (string * t) list -> t 138 | val unshared_construct: string -> t list -> t 139 | val unshared_crecord: string -> (string * t) list -> t 140 | val unshared_list: t list -> t 141 | val unshared_array: t array -> t 142 | 143 | (* Representing recursion *) 144 | val of_lazy : t lazy_t -> t 145 | 146 | val explicit_sharing: t -> t 147 | (** Rewrite a value, introducing let-binders to make sharing explicit. *) 148 | 149 | val print_as_is: t -> PPrint.document 150 | (** Print the value as it is (without changing sharing) to a 151 | [PPrint.document]. *) 152 | 153 | val print: t -> PPrint.document 154 | (** Print the value with explicit sharing to a [PPrint.document]. 155 | [print t == print_as_is (explicit_sharing t)]. *) 156 | 157 | val format_document : Format.formatter -> PPrint.document -> unit 158 | (** Print a PPrint document on a formatter while trying to follow respect the 159 | margin specification of the formatter. *) 160 | 161 | val format_as_is: Format.formatter -> t -> unit 162 | (** Format the value as it is (without changing sharing) to a 163 | [Format.formatter] *) 164 | 165 | val format: Format.formatter -> t -> unit 166 | (** Format the value with explicit sharing to a [Format.formatter]. 167 | [format t == format_as_is (explicit_sharing t)]. 168 | 169 | To display cmon values in a top-level, you can use #install_printer format. 170 | For instance: 171 | 172 | utop # Cmon.unit;; 173 | - : Cmon.t = Cmon.Unit 174 | utop # #install_printer Cmon.format;; 175 | utop # Cmon.unit;; 176 | - : Cmon.t = () 177 | *) 178 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cmon) 3 | (public_name cmon) 4 | (libraries pprint grenier.fastdom grenier.binder_introducer)) 5 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune runtest 3 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (modules test) 4 | (libraries cmon)) 5 | 6 | (rule 7 | (alias runtest) 8 | (action 9 | (with-stdout-to test.exe.output (run %{exe:test.exe})))) 10 | 11 | (rule 12 | (alias runtest) 13 | (deps test.exe) 14 | (action (diff test.expected test.exe.output))) 15 | -------------------------------------------------------------------------------- /tests/test.expected: -------------------------------------------------------------------------------- 1 | unit: 2 | () 3 | 4 | false: 5 | false 6 | 7 | true: 8 | true 9 | 10 | 0: 11 | 0 12 | 13 | 1: 14 | 1 15 | 16 | 2: 17 | 2 18 | 19 | -1: 20 | -1 21 | 22 | -2: 23 | -2 24 | 25 | 0.: 26 | 0. 27 | 28 | 1.: 29 | 1. 30 | 31 | -0.: 32 | -0. 33 | 34 | -1.: 35 | -1. 36 | 37 | +inf: 38 | infinity 39 | 40 | -inf: 41 | neg_infinity 42 | 43 | nan: 44 | nan 45 | 46 | max_float: 47 | 1.79769313486231571e+308 48 | 49 | min_float: 50 | 2.22507385850720138e-308 51 | 52 | 'a': 53 | 'a' 54 | 55 | '\x00': 56 | '\000' 57 | 58 | '\xFF': 59 | '\255' 60 | 61 | '\t': 62 | '\t' 63 | 64 | '\n': 65 | '\n' 66 | 67 | "foo": 68 | "foo" 69 | 70 | "\"foo\"": 71 | "\"foo\"" 72 | 73 | "foo\nbar": 74 | "foo\nbar" 75 | 76 | (1, true): 77 | (1, true) 78 | 79 | (1, true, ...): 80 | (1, true, 1, true, 1, true) 81 | 82 | (1, true, ..., ...): 83 | ( 84 | 1, 85 | true, 86 | 1, 87 | true, 88 | 1, 89 | true, 90 | 1, 91 | true, 92 | 1, 93 | true, 94 | 1, 95 | true, 96 | 1, 97 | true, 98 | 1, 99 | true, 100 | 1, 101 | true 102 | ) 103 | 104 | [1; true]: 105 | [ 1; true ] 106 | 107 | [1; true; ...]: 108 | [ 1; true; 1; true; 1; true ] 109 | 110 | [1; true; ...; ...]: 111 | [ 112 | 1; 113 | true; 114 | 1; 115 | true; 116 | 1; 117 | true; 118 | 1; 119 | true; 120 | 1; 121 | true; 122 | 1; 123 | true; 124 | 1; 125 | true; 126 | 1; 127 | true; 128 | 1; 129 | true 130 | ] 131 | 132 | 1 :: true :: xs: 133 | 1 :: true :: xs 134 | 135 | 1 :: true :: ... :: xs: 136 | 1 :: true :: 1 :: true :: 1 :: true :: xs 137 | 138 | 1 :: true :: ... ... :: xs: 139 | 1 140 | :: true 141 | :: 1 142 | :: true 143 | :: 1 144 | :: true 145 | :: 1 146 | :: true 147 | :: 1 148 | :: true 149 | :: 1 150 | :: true 151 | :: 1 152 | :: true 153 | :: 1 154 | :: true 155 | :: 1 156 | :: true 157 | :: xs 158 | 159 | nested-1: 160 | [ ([ (); [] ], ([], ())); [ ([], ()); [ (); [] ] ] ] 161 | 162 | nested-2: 163 | ( 164 | [ 165 | ( 166 | [ ([ (); [] ], ([], ())); [ ([], ()); [ (); [] ] ] ], 167 | ([ ([], ()); [ (); [] ] ], ([ (); [] ], ([], ()))) 168 | ); 169 | [ 170 | ([ ([], ()); [ (); [] ] ], ([ (); [] ], ([], ()))); 171 | [ ([ (); [] ], ([], ())); [ ([], ()); [ (); [] ] ] ] 172 | ] 173 | ], 174 | ( 175 | [ 176 | ([ ([], ()); [ (); [] ] ], ([ (); [] ], ([], ()))); 177 | [ ([ (); [] ], ([], ())); [ ([], ()); [ (); [] ] ] ] 178 | ], 179 | ( 180 | [ ([ (); [] ], ([], ())); [ ([], ()); [ (); [] ] ] ], 181 | ([ ([], ()); [ (); [] ] ], ([ (); [] ], ([], ()))) 182 | ) 183 | ) 184 | ) 185 | 186 | data-constructors-1: 187 | (None, Some (), Pair (1, 2)) 188 | 189 | data-constructors-2: 190 | (None, Some (), Pair (1, 2)) 191 | 192 | record-1: 193 | { contents = 1; } 194 | 195 | record-2: 196 | { a = 1; b = true; } 197 | 198 | record-3: 199 | { a = 1; b = true; a = 1; b = true; a = 1; b = true; } 200 | 201 | record-4: 202 | { 203 | a = 1; 204 | b = true; 205 | a = 1; 206 | b = true; 207 | a = 1; 208 | b = true; 209 | a = 1; 210 | b = true; 211 | a = 1; 212 | b = true; 213 | a = 1; 214 | b = true; 215 | a = 1; 216 | b = true; 217 | a = 1; 218 | b = true; 219 | a = 1; 220 | b = true; 221 | } 222 | 223 | inline-record-1: 224 | R1 { contents = 1; } 225 | 226 | inline-record-2: 227 | R2 { a = 1; b = true; } 228 | 229 | inline-record-3: 230 | R3 { a = 1; b = true; a = 1; b = true; a = 1; b = true; } 231 | 232 | inline-record-4: 233 | R4 { 234 | a = 1; 235 | b = true; 236 | a = 1; 237 | b = true; 238 | a = 1; 239 | b = true; 240 | a = 1; 241 | b = true; 242 | a = 1; 243 | b = true; 244 | a = 1; 245 | b = true; 246 | a = 1; 247 | b = true; 248 | a = 1; 249 | b = true; 250 | a = 1; 251 | b = true; 252 | } 253 | 254 | shared-terms: 255 | let v0 = let v1 = ("test", 1) in (v1, v1) in 256 | (let v2 = let v3 = ("test", 1) in (v3, v3) in (v2, v2, v0), v0) 257 | 258 | rec-term1: 259 | let rec v0 = 1 :: v0 in 260 | v0 261 | 262 | rec-term2: 263 | let rec v0 = 1 :: 2 :: v0 in 264 | v0 265 | 266 | rec-term4: 267 | let rec v0 = 1 :: 2 :: v0 in 268 | v0 269 | 270 | rec-term4': 271 | let rec v0 = 1 :: v1 and v1 = 2 :: v0 in 272 | (v0, v1) 273 | 274 | rec-term5: 275 | let rec v0 = 1 :: v1 and v1 = 2 :: v0 in 276 | let v2 = ("test", 1) in 277 | (v0, v1, v2, v2) 278 | 279 | rec-term6: 280 | let v0 = ("test", 1) in 281 | let rec v1 = v0 :: v2 and v2 = v0 :: v1 in 282 | (v1, v2) 283 | 284 | binding-group: 285 | let v0 = K A and v1 = K B in 286 | let rec v2 = v0 :: v3 and v3 = v1 :: v2 in 287 | let v4 = K C in 288 | (v0, v1, v2, v3, v4, v4) 289 | 290 | regression-test-scope-limit: 291 | let v0 = Block (0, Done) in 292 | let v1 = blockTag v0 and v2 = blockFields v0 in 293 | or ( 294 | and (= (v1, 0), (_ is (Done () Fields)) v2), 295 | let v3 = fieldNext v2 in 296 | and ( 297 | = (v1, 1), 298 | (_ is (Done () Fields)) (fieldNext v3), 299 | (_ is (Field (Value Fields) Fields)) v3, 300 | (_ is (Field (Value Fields) Fields)) v2 301 | ) 302 | ) 303 | 304 | -------------------------------------------------------------------------------- /tests/test.ml: -------------------------------------------------------------------------------- 1 | let print name value = 2 | print_string name; 3 | print_endline ":"; 4 | PPrint.ToChannel.pretty 0.9 80 stdout (Cmon.print value); 5 | print_newline (); 6 | print_newline () 7 | 8 | let short_args = Cmon.[int 1; bool true] 9 | let mid_args = short_args @ short_args @ short_args 10 | let long_args = mid_args @ mid_args @ mid_args 11 | 12 | let short_fields = Cmon.["a", int 1; "b", bool true] 13 | let mid_fields = short_fields @ short_fields @ short_fields 14 | let long_fields = mid_fields @ mid_fields @ mid_fields 15 | 16 | let () = 17 | (* Base types *) 18 | print "unit" Cmon.unit; 19 | print "false" (Cmon.bool false); 20 | print "true" (Cmon.bool true); 21 | 22 | (* Integers *) 23 | print "0" (Cmon.int 0); 24 | print "1" (Cmon.int 1); 25 | print "2" (Cmon.int 2); 26 | print "-1" (Cmon.int (-1)); 27 | print "-2" (Cmon.int (-2)); 28 | 29 | (* Floats *) 30 | print "0." (Cmon.float 0.0); 31 | print "1." (Cmon.float 1.0); 32 | print "-0." (Cmon.float (-0.0)); 33 | print "-1." (Cmon.float (-1.0)); 34 | print "+inf" (Cmon.float ( 1.0 /. 0.0)); 35 | print "-inf" (Cmon.float (-1.0 /. 0.0)); 36 | print "nan" (Cmon.float ( 0.0 /. 0.0)); 37 | print "max_float" (Cmon.float max_float); 38 | print "min_float" (Cmon.float min_float); 39 | 40 | (* Chars *) 41 | print "'a'" (Cmon.char 'a'); 42 | print "'\\x00'" (Cmon.char '\x00'); 43 | print "'\\xFF'" (Cmon.char '\xFF'); 44 | print "'\\t'" (Cmon.char '\t'); 45 | print "'\\n'" (Cmon.char '\n'); 46 | 47 | (* Strings *) 48 | print "\"foo\"" (Cmon.string "foo"); 49 | print "\"\\\"foo\\\"\"" (Cmon.string "\"foo\""); 50 | print "\"foo\\nbar\"" (Cmon.string "foo\nbar"); 51 | 52 | (* Tuple *) 53 | print "(1, true)" (Cmon.tuple short_args); 54 | print "(1, true, ...)" (Cmon.tuple mid_args); 55 | print "(1, true, ..., ...)" (Cmon.tuple long_args); 56 | 57 | (* Terminated lists *) 58 | print "[1; true]" (Cmon.list short_args); 59 | print "[1; true; ...]" (Cmon.list mid_args); 60 | print "[1; true; ...; ...]" (Cmon.list long_args); 61 | 62 | (* Open lists *) 63 | let open_list xs = List.fold_right Cmon.cons xs (Cmon.constant "xs") in 64 | print "1 :: true :: xs" (open_list short_args); 65 | print "1 :: true :: ... :: xs" (open_list mid_args); 66 | print "1 :: true :: ... ... :: xs" (open_list long_args); 67 | 68 | (* Nested lists and tuples *) 69 | let step = ref 0 in 70 | let rec deep n = 71 | incr step; 72 | let is_tuple = !step land 1 = 0 in 73 | if n = 0 then ( 74 | if is_tuple 75 | then Cmon.unit 76 | else Cmon.nil 77 | ) else ( 78 | let left = deep (n - 1) in 79 | let right = deep (n - 1) in 80 | if is_tuple 81 | then Cmon.tuple [left; right] 82 | else Cmon.list [left; right] 83 | ) 84 | in 85 | print "nested-1" (deep 3); 86 | print "nested-2" (deep 6); 87 | 88 | (* Constructors *) 89 | print "data-constructors-1" 90 | (Cmon.tuple [ 91 | Cmon.constant "None"; 92 | Cmon.constructor "Some" Cmon.unit; 93 | Cmon.constructor "Pair" (Cmon.tuple [Cmon.int 1; Cmon.int 2]); 94 | ]); 95 | 96 | print "data-constructors-2" 97 | (Cmon.tuple [ 98 | Cmon.construct "None" []; 99 | Cmon.construct "Some" [Cmon.unit]; 100 | Cmon.construct "Pair" [Cmon.int 1; Cmon.int 2]; 101 | ]); 102 | 103 | (* Records *) 104 | print "record-1" (Cmon.record ["contents", Cmon.int 1]); 105 | print "record-2" (Cmon.record short_fields); 106 | print "record-3" (Cmon.record mid_fields); 107 | print "record-4" (Cmon.record long_fields); 108 | 109 | (* Inline records *) 110 | print "inline-record-1" (Cmon.crecord "R1" ["contents", Cmon.int 1]); 111 | print "inline-record-2" (Cmon.crecord "R2" short_fields); 112 | print "inline-record-3" (Cmon.crecord "R3" mid_fields); 113 | print "inline-record-4" (Cmon.crecord "R4" long_fields); 114 | 115 | (* Sharing test *) 116 | let shared_term1 = 117 | Cmon.tuple [Cmon.string "test"; Cmon.int 1] in 118 | let shared_term2 = 119 | Cmon.tuple [shared_term1; shared_term1] in 120 | let shared_term1' = 121 | Cmon.tuple [Cmon.string "test"; Cmon.int 1] in 122 | let shared_term2' = 123 | Cmon.tuple [shared_term1'; shared_term1'] in 124 | let shared_term3 = 125 | Cmon.tuple [shared_term2; shared_term2; shared_term2'] in 126 | let shared_term4 = 127 | Cmon.tuple [shared_term3; shared_term2'] in 128 | print "shared-terms" shared_term4; 129 | 130 | (* Recursion test *) 131 | let rec rec_term1 = lazy (Cmon.cons (Cmon.int 1) (Cmon.of_lazy rec_term1)) in 132 | print "rec-term1" (Cmon.of_lazy rec_term1); 133 | let rec rec_term2 = 134 | lazy (Cmon.cons (Cmon.int 1) (Cmon.cons (Cmon.int 2) 135 | (Cmon.of_lazy rec_term2))) in 136 | print "rec-term2" (Cmon.of_lazy rec_term2); 137 | (*let rec rec_term3 = lazy (Cmon.of_lazy rec_term3) in 138 | print "rec-term3" (Cmon.of_lazy rec_term3);*) 139 | let rec rec_term4 = lazy (Cmon.cons (Cmon.int 1) (Cmon.of_lazy rec_term4')) 140 | and rec_term4'= lazy (Cmon.cons (Cmon.int 2) (Cmon.of_lazy rec_term4)) 141 | in 142 | print "rec-term4" (Cmon.of_lazy rec_term4); 143 | print "rec-term4'" (Cmon.tuple [Cmon.of_lazy rec_term4; Cmon.of_lazy rec_term4']); 144 | print "rec-term5" (Cmon.tuple [Cmon.of_lazy rec_term4; Cmon.of_lazy rec_term4'; shared_term1; shared_term1]); 145 | let rec rec_term6 = lazy (Cmon.cons shared_term1 (Cmon.of_lazy rec_term6')) 146 | and rec_term6'= lazy (Cmon.cons shared_term1 (Cmon.of_lazy rec_term6)) 147 | in 148 | print "rec-term6" (Cmon.tuple [Cmon.of_lazy rec_term6; Cmon.of_lazy rec_term6']); 149 | 150 | (* Multiple let bindings group *) 151 | print "binding-group" ( 152 | (* 153 | let x = K A 154 | and y = K B 155 | in 156 | let rec 157 | z = x :: w 158 | and 159 | w = y :: z 160 | in 161 | let a = K C in 162 | (x, y, z, w, a, a) 163 | *) 164 | let t_x = Cmon.constructor "K" (Cmon.constant "A") in 165 | let t_y = Cmon.constructor "K" (Cmon.constant "B") in 166 | let rec 167 | t_z = lazy (Cmon.cons t_x (Cmon.of_lazy t_w)) 168 | and 169 | t_w = lazy (Cmon.cons t_y (Cmon.of_lazy t_z)) 170 | in 171 | let t_a = Cmon.constructor "K" (Cmon.constant "C") in 172 | Cmon.tuple [t_x; t_y; Cmon.of_lazy t_z; Cmon.of_lazy t_w; t_a; t_a] 173 | ); 174 | 175 | (* Regression testing: bug with scope limit *) 176 | print "regression-test-scope-limit" ( 177 | let v_4 = Cmon.construct "Block" [Cmon.int 0; Cmon.Constant "Done"] in 178 | let v_3 = Cmon.construct "blockTag" [v_4] in 179 | let v_2 = Cmon.construct "blockFields" [v_4] in 180 | let v_1 = Cmon.construct "fieldNext" [v_2] in 181 | Cmon.construct "or" [ 182 | Cmon.construct "and" [ 183 | Cmon.construct "=" [v_3; Cmon.int 0]; 184 | Cmon.construct "(_ is (Done () Fields))" [v_2]; 185 | ]; 186 | Cmon.construct "and" [ 187 | Cmon.construct "=" [v_3; Cmon.int 1]; 188 | Cmon.construct "(_ is (Done () Fields))" 189 | [Cmon.construct "fieldNext" [v_1]]; 190 | Cmon.construct "(_ is (Field (Value Fields) Fields))" [v_1]; 191 | Cmon.construct "(_ is (Field (Value Fields) Fields))" [v_2]; 192 | ]; 193 | ] 194 | ); 195 | --------------------------------------------------------------------------------