← Back to branch summary

~ubuntu-branches/debian/sid/ocaml/sid

« back to all changes in this revision

Viewing changes to testsuite/tests/typing-fstclassmod/fstclassmod.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu
  • Date: 2011-04-21 21:35:08 UTC
  • mfrom: (1.1.11 upstream) (12.1.14 sid)
  • Revision ID: james.westby@ubuntu.com-20110421213508-kg34453aqmb0moha
* Fixes related to -output-obj with g++ (in debian/patches):
  - add Declare-primitive-name-table-as-const-char
  - add Avoid-multiple-declarations-in-generated-.c-files-in
  - fix Embed-bytecode-in-C-object-when-using-custom: the closing
    brace for extern "C" { ... } was missing in some cases

Show diffs side-by-side

added added

removed removed

Lines of Context:
testsuite/tests/typing-fstclassmod/fstclassmod.ml
 
1
(* Example of algorithm parametrized with modules *)
 
2
 
 
3
let sort (type s) set l =
 
4
  let module Set = (val set : Set.S with type elt = s) in
 
5
  Set.elements (List.fold_right Set.add l Set.empty)
 
6
 
 
7
let make_set (type s) cmp =
 
8
  let module S = Set.Make(struct
 
9
    type t = s
 
10
    let compare = cmp
 
11
  end) in
 
12
  (module S : Set.S with type elt = s)
 
13
 
 
14
let both l =
 
15
  List.map
 
16
    (fun set -> sort set l)
 
17
    [ make_set compare; make_set (fun x y -> compare y x) ]
 
18
 
 
19
let () =
 
20
  print_endline (String.concat "  " (List.map (String.concat "/") (both ["abc";"xyz";"def"])))
 
21
 
 
22
 
 
23
(* Hiding the internal representation *)
 
24
 
 
25
module type S = sig
 
26
  type t
 
27
  val to_string: t -> string
 
28
  val apply: t -> t
 
29
  val x: t
 
30
end
 
31
 
 
32
let create (type s) to_string apply x =
 
33
  let module M = struct
 
34
    type t = s
 
35
    let to_string = to_string
 
36
    let apply = apply
 
37
    let x = x
 
38
  end in
 
39
  (module M : S with type t = s)
 
40
 
 
41
let forget (type s) x =
 
42
  let module M = (val x : S with type t = s) in
 
43
  (module M : S)
 
44
 
 
45
let print x =
 
46
  let module M = (val x : S) in
 
47
  print_endline (M.to_string M.x)
 
48
 
 
49
let apply x =
 
50
  let module M = (val x : S) in
 
51
  let module N = struct
 
52
    include M
 
53
    let x = apply x
 
54
  end in
 
55
  (module N : S)
 
56
 
 
57
let () =
 
58
  let int = forget (create string_of_int succ 0) in
 
59
  let str = forget (create (fun s -> s) (fun s -> s ^ s) "X") in
 
60
  List.iter print (List.map apply [int; apply int; apply (apply str)])
 
61
 
 
62
 
 
63
(* Existential types + type equality witnesses -> pseudo GADT *)
 
64
 
 
65
module TypEq : sig
 
66
  type ('a, 'b) t
 
67
  val apply: ('a, 'b) t -> 'a -> 'b
 
68
  val refl: ('a, 'a) t
 
69
  val sym: ('a, 'b) t -> ('b, 'a) t
 
70
end = struct
 
71
  type ('a, 'b) t = unit
 
72
  let apply _ = Obj.magic
 
73
  let refl = ()
 
74
  let sym () = ()
 
75
end
 
76
 
 
77
 
 
78
module rec Typ : sig
 
79
  module type PAIR = sig
 
80
    type t
 
81
    type t1
 
82
    type t2
 
83
    val eq: (t, t1 * t2) TypEq.t
 
84
    val t1: t1 Typ.typ
 
85
    val t2: t2 Typ.typ
 
86
  end
 
87
 
 
88
  type 'a typ =
 
89
    | Int of ('a, int) TypEq.t
 
90
    | String of ('a, string) TypEq.t
 
91
    | Pair of (module PAIR with type t = 'a)
 
92
end = struct
 
93
  module type PAIR = sig
 
94
    type t
 
95
    type t1
 
96
    type t2
 
97
    val eq: (t, t1 * t2) TypEq.t
 
98
    val t1: t1 Typ.typ
 
99
    val t2: t2 Typ.typ
 
100
  end
 
101
 
 
102
  type 'a typ =
 
103
    | Int of ('a, int) TypEq.t
 
104
    | String of ('a, string) TypEq.t
 
105
    | Pair of (module PAIR with type t = 'a)
 
106
end
 
107
 
 
108
open Typ
 
109
 
 
110
let int = Int TypEq.refl
 
111
 
 
112
let str = String TypEq.refl
 
113
 
 
114
let pair (type s1) (type s2) t1 t2 =
 
115
  let module P = struct
 
116
    type t = s1 * s2
 
117
    type t1 = s1
 
118
    type t2 = s2
 
119
    let eq = TypEq.refl
 
120
    let t1 = t1
 
121
    let t2 = t2
 
122
  end in
 
123
  let pair = (module P : PAIR with type t = s1 * s2) in
 
124
  Pair pair
 
125
 
 
126
module rec Print : sig
 
127
  val to_string: 'a Typ.typ -> 'a -> string
 
128
end = struct
 
129
  let to_string (type s) t x =
 
130
    match t with
 
131
    | Int eq -> string_of_int (TypEq.apply eq x)
 
132
    | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
 
133
    | Pair p ->
 
134
        let module P = (val p : PAIR with type t = s) in
 
135
        let (x1, x2) = TypEq.apply P.eq x in
 
136
        Printf.sprintf "(%s,%s)" (Print.to_string P.t1 x1) (Print.to_string P.t2 x2)
 
137
end
 
138
 
 
139
let () =
 
140
  print_endline (Print.to_string int 10);
 
141
  print_endline (Print.to_string (pair int (pair str int)) (123, ("A", 456)))
 
142