Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 84 lines (74 sloc) 2.753 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 type printer = { f : 'a. 'a -> string option }
19 let printers = ref ([] : printer list)
20 let register p = printers := p :: !printers
21 let rec print ?(depth=1000) x =
22 let rec aux = function
23 | [] -> Printf.sprintf "$%s$" (BaseObj.dump ~depth x)
24 | h :: t ->
25 match h.f x with
26 | None -> aux t
27 | Some s -> s in
28 aux !printers
29
30 let pp ?(depth=1000) fmt a = Format.pp_print_string fmt (print ~depth a)
31
32 let rec simple_print ?(depth=1000) x =
33 let rec aux = function
34 | [] -> Printf.sprintf "%s" (BaseObj.dump ~depth x)
35 | h :: t ->
36 match h.f x with
37 | None -> aux t
38 | Some s -> s in
39 aux !printers
40
41
42 let true_ _ = true
43 let false_ _ = false
44
45 let bool x = Obj.obj x == true || Obj.obj x == false
46 let string x = Obj.tag x = Obj.string_tag
47 let option ?(a=true_) x =
48 let t = Obj.tag x in
49 t = Obj.int_tag && (Obj.obj x = 0) || (* none *)
50 t = 0 && (* some *)
51 Obj.size x = 1 &&
52 a (Obj.field x 0)
53 let array ?(tag=0) ?a x =
54 Obj.tag x = tag &&
55 match a with
56 | None -> true
57 | Some check_a ->
58 let i = ref 0 in
59 let s = Obj.size x in
60 let ok = ref true in
61 while !i < s && !ok do
62 ok := check_a (Obj.field x !i);
63 incr i;
64 done;
65 !ok
66 let unit x = Obj.obj x = 0
67 let int ?(plus=true_) x = Obj.is_int x && plus (Obj.obj x : int)
68 let tuple0 = unit
69 let tuple1 ?(f1=true_) x =
70 Obj.tag x = 0 && Obj.size x = 1 && f1 (Obj.field x 0)
71 let tuple2 ?(f1=true_) ?(f2=true_) x =
72 Obj.tag x = 0 && Obj.size x = 2 && f1 (Obj.field x 0) && f2 (Obj.field x 1)
73 let tuple3 ?(f1=true_) ?(f2=true_) ?(f3=true_) x =
74 Obj.tag x = 0 && Obj.size x = 3 && f1 (Obj.field x 0) && f2 (Obj.field x 1) && f3 (Obj.field x 2)
75 let tuple4 ?(f1=true_) ?(f2=true_) ?(f3=true_) ?(f4=true_) x =
76 Obj.tag x = 0 && Obj.size x = 4 && f1 (Obj.field x 0) && f2 (Obj.field x 1) && f3 (Obj.field x 2) && f4 (Obj.field x 3)
77 let tuple_n checkers x =
78 let n = List.length checkers in
79 Obj.tag x = 0 && Obj.size x = n &&
80 let rec aux i = function
81 | [] -> true
82 | h :: t -> h (Obj.field x i) && aux (i+1) t in
83 aux 0 checkers
Something went wrong with that request. Please try again.