A collection of experiments, more or less organized.
Start working on kind
+149
-11
+109
-6
lib/pidgin/kind.ml
+109
-6
lib/pidgin/kind.ml
···
1
1
type t =
2
2
| Any
3
+
(* KLUDGE: Since we do not perform "real unification". Any is mostly here
4
+
for dealing with empty list. When we can't compute a proper
5
+
type for something. Since the goal of Kind is not to
6
+
perform "type checking" but to produce UI on top of
7
+
validation, let's assume that this is ... ok*)
3
8
| Or of t * t
4
9
| Null
5
10
| Unit
···
12
17
| Pair of t * t
13
18
| List of t
14
19
| Constr of string * t option
15
-
| Record of (string * t) list
20
+
| Record of fields
21
+
22
+
and fields = t Util.String_map.t
23
+
24
+
let any = Any
25
+
let or_ a b = Or (a, b)
26
+
let null = Null
27
+
let unit = Unit
28
+
let bool = Bool
29
+
let int = Int
30
+
let int64 = Int64
31
+
let float = Float
32
+
let char = Char
33
+
let string = String
34
+
let pair a b = Pair (a, b)
35
+
let list k = List k
36
+
let constr ?value k = Constr (k, value)
37
+
let record fields = Record (Util.String_map.of_list fields)
38
+
39
+
let rec equal a b =
40
+
match a, b with
41
+
| Any, Any
42
+
| Null, Null
43
+
| Unit, Unit
44
+
| Bool, Bool
45
+
| Int, Int
46
+
| Int64, Int64
47
+
| Float, Float
48
+
| Char, Char
49
+
| String, String -> true
50
+
| Or (a, b), Or (x, y) | Pair (a, b), Pair (x, y) -> equal a x && equal b y
51
+
| List a, List b -> equal a b
52
+
| Constr (ka, va), Constr (kb, vb) ->
53
+
String.equal ka kb && Option.equal equal va vb
54
+
| Record a, Record b -> Util.String_map.equal equal a b
55
+
| Any, _
56
+
| Or (_, _), _
57
+
| Null, _
58
+
| Unit, _
59
+
| Bool, _
60
+
| Int, _
61
+
| Int64, _
62
+
| Float, _
63
+
| Char, _
64
+
| String, _
65
+
| Pair (_, _), _
66
+
| List _, _
67
+
| Constr (_, _), _
68
+
| Record _, _ -> false
69
+
;;
16
70
17
71
let rec to_string = function
72
+
(* NOTE: I guess that this function is probably useful only for testing
73
+
puprpose so let's be lax on the way that we display stuff. *)
18
74
| Any -> "any"
19
75
| Null -> "null"
20
76
| Unit -> "unit"
···
29
85
| List xs -> "list(" ^ to_string xs ^ ")"
30
86
| Constr (k, Some v) -> "#" ^ k ^ "(" ^ to_string v ^ ")"
31
87
| Constr (k, None) -> "#" ^ k
32
-
| Record _ -> assert false
88
+
| Record fields ->
89
+
let fields =
90
+
(* TODO: Can be improved later. *)
91
+
fields
92
+
|> Util.String_map.to_list
93
+
|> List.map (fun (k, v) -> "[" ^ k ^ "] " ^ to_string v)
94
+
|> String.concat "; "
95
+
in
96
+
"record{ " ^ fields ^ " }"
33
97
;;
34
98
35
-
(* module S = Set.Make (struct *)
36
-
(* type nonrec t = t *)
37
-
(* let compare *)
38
-
(* end) *)
99
+
module S = Set.Make (struct
100
+
type nonrec t = t
101
+
102
+
let compare a b =
103
+
(* NOTE: Order si not really important. *)
104
+
let a = to_string a
105
+
and b = to_string b in
106
+
String.compare a b
107
+
;;
108
+
end)
109
+
110
+
let rec from_repr = function
111
+
| Repr.Null -> null
112
+
| Repr.Unit -> unit
113
+
| Repr.Bool _ -> bool
114
+
| Repr.Int _ -> int
115
+
| Repr.Int64 _ -> int64
116
+
| Repr.Float _ -> float
117
+
| Repr.Char _ -> char
118
+
| Repr.String _ -> string
119
+
| Repr.Pair (a, b) -> pair (from_repr a) (from_repr b)
120
+
| Repr.Constr (k, v) ->
121
+
let value = Option.map from_repr v in
122
+
constr ?value k
123
+
| Repr.Record fields ->
124
+
fields
125
+
|> Repr.fields_to_assoc
126
+
|> List.map (fun (k, v) -> k, from_repr v)
127
+
|> record
128
+
| Repr.List _ -> assert false
129
+
130
+
and from_list xs =
131
+
match
132
+
(* KLUDGE: It can obviously be improved since we are doing a lot of
133
+
traversal just for computing something trivial but it is ok for
134
+
the moment since we are not expecting big big lists. *)
135
+
xs
136
+
|> List.fold_left (fun acc t -> S.add (from_repr t) acc) S.empty
137
+
|> S.to_list
138
+
with
139
+
| [] -> Any
140
+
| x :: xs -> List.fold_left (fun prev t -> or_ t prev) x xs
141
+
;;
+32
lib/pidgin/kind.mli
+32
lib/pidgin/kind.mli
···
1
+
(** Represent the "main shape" of a term. *)
2
+
3
+
(** The main idea of a kind is to be able to derive the global shape for a
4
+
formlet using the [kind] of a validation. *)
5
+
6
+
(** {1 Types} *)
7
+
8
+
(** Describes the kind of a term. *)
9
+
type t
10
+
11
+
(** {1 Build kinds} *)
12
+
13
+
val any : t
14
+
val or_ : t -> t -> t
15
+
val null : t
16
+
val unit : t
17
+
val bool : t
18
+
val int : t
19
+
val int64 : t
20
+
val float : t
21
+
val char : t
22
+
val string : t
23
+
val pair : t -> t -> t
24
+
val list : t -> t
25
+
val constr : ?value:t -> string -> t
26
+
val record : (string * t) list -> t
27
+
val from_repr : Repr.t -> t
28
+
29
+
(** {1 Utils} *)
30
+
31
+
val equal : t -> t -> bool
32
+
val to_string : t -> string
+5
-5
lib/pidgin/repr.ml
+5
-5
lib/pidgin/repr.ml
···
1
-
module Fields = Stdlib.Map.Make (String)
2
-
3
1
type t =
4
2
| Null
5
3
| Unit
···
14
12
| Constr of string * t option
15
13
| Record of fields
16
14
17
-
and fields = t Fields.t
15
+
and fields = t Util.String_map.t
16
+
17
+
let fields_to_assoc = Util.String_map.to_list
18
18
19
19
type 'a conv = 'a -> t
20
20
···
33
33
| List a, List b -> List.equal equal a b
34
34
| Constr (ka, va), Constr (kb, vb) ->
35
35
String.equal ka kb && Option.equal equal va vb
36
-
| Record a, Record b -> Fields.equal equal a b
36
+
| Record a, Record b -> Util.String_map.equal equal a b
37
37
| Null, _
38
38
| Unit, _
39
39
| Bool _, _
···
111
111
;;
112
112
113
113
let list conv xs = xs |> List.map conv |> Lit.list
114
-
let record fields = Record (Fields.of_list fields)
114
+
let record fields = Record (Util.String_map.of_list fields)
115
115
let option some = Option.fold ~none:Lit.null ~some
116
116
117
117
let result ok err =
+1
lib/pidgin/repr.mli
+1
lib/pidgin/repr.mli
+1
lib/pidgin/util.ml
+1
lib/pidgin/util.ml
···
1
+
module String_map = Stdlib.Map.Make (String)
+1
lib/pidgin/util.mli
+1
lib/pidgin/util.mli
···
1
+
module String_map : Map.S with type key = string