cdml.ml 3.24 KB
Newer Older
1
2
3
4
open CDuce_all

type any

5
6
7
8
type 'a cd2ml = Value.t -> 'a

type 'a ml2cd = 'a -> Value.t

9
10
let initialize modname =
  let cu = Types.CompUnit.mk ( Ident.U.mk_latin1 modname ) in
11
12
13
  (try Librarian.import cu;
   with Librarian.NoImplementation _ -> 
     failwith ("Cdml: no implementation found for CDuce module " ^ modname));
14
15
16
  Librarian.run cu;
  cu

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
let identity x = x

let mk_atom s = Value.Atom ( Atoms.V.mk_ascii s )

let atom_to_string v = Ns.QName.to_string ( Atoms.V.value v )

let mk_qname s = Ns.mk_ascii "", Encodings.Utf8.mk s

let record_field map s =
  let pool = Ident.LabelPool.mk ( mk_qname s ) in
  Ident.LabelMap.assoc pool map

let ocaml2cduce_arrow fa fb f =
  let func = fun x -> fb ( f ( fa x ) ) in
  Value.Abstraction ( [], func )

33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
let ocaml2cduce_bool = function 
  | true -> Value.Atom ( Atoms.V.mk_ascii "true" )
  | false -> Value.Atom ( Atoms.V.mk_ascii "false" )

let cduce2ocaml_bool = function
  | Value.Atom a -> 
      let v = Ns.QName.to_string ( Atoms.V.value a ) in
      compare v "true" = 0
  | _ -> assert false

let ocaml2cduce_char c =
  let v = Chars.V.mk_char c in Value.Char v

let cduce2ocaml_char = function
  | Value.Char c -> Chars.V.to_char c 
  | _ -> assert false

let ocaml2cduce_int i =
  let s = string_of_int i in Value.Integer ( Intervals.V.mk s )

let cduce2ocaml_int = function
  | Value.Integer i -> Intervals.V.get_int i
  | _ -> assert false

57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
let ocaml2cduce_list f l =
  Value.sequence ( List.map f l )

let rec cduce2ocaml_list_aux tail f = function
  | Value.Atom _ -> tail
  | Value.Pair ( hd, tl ) -> 
      cduce2ocaml_list_aux ( tail @ [ f hd ] ) f tl
  | Value.Concat ( l1, l2 ) ->
      cduce2ocaml_list_aux ( cduce2ocaml_list_aux tail f l1 ) f l2
  | _ -> assert false

let cduce2ocaml_list f = cduce2ocaml_list_aux [] f

let ocaml2cduce_option f = function
  | None -> Value.nil
  | Some value -> f value

let cduce2ocaml_option f = function
  | Value.Atom v when Ns.QName.to_string ( Atoms.V.value v ) = "nil" -> None
  | value -> Some ( f value )

let ocaml2cduce_unit () =
  Value.sequence []

let cduce2ocaml_unit = fun _ -> ()

let ocaml2cduce_ref f1 f2 r =
  let nget = Ns.mk_ascii "", Encodings.Utf8.mk "get" in
  let fget = fun _ -> f1 !r in
  let fget = Value.Abstraction ( [], fget ) in
  let nset = Ns.mk_ascii "", Encodings.Utf8.mk "set" in
  let fset = fun v -> r := f2 v; ocaml2cduce_unit () in
  let fset = Value.Abstraction ( [], fset ) in
  Value.vrecord [ nget, fget; nset, fset ]

let cduce2ocaml_ref f = function
  | _ -> assert false

95
96
97
98
99
100
let ocaml2cduce_string s =
  Value.string_latin1 s

let cduce2ocaml_string s = 
  Value.get_string_latin1 s

101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
let ocaml2cduce_tuple_2 fa fb ( a, b ) =
  Value.Pair ( fa a, fb b )

let ocaml2cduce_tuple_3 fa fb fc ( a, b, c ) =
  Value.Pair ( fa a, Value.Pair ( fb b, fc c ) )

let ocaml2cduce_tuple_4 fa fb fc fd ( a, b, c, d ) =
  Value.Pair ( fa a, Value.Pair ( fb b, Value.Pair ( fc c, fd d ) ) )

let cduce2ocaml_tuple_2 fa fb = function
  | Value.Pair ( a, b ) -> fa a, fb b
  | _ -> assert false

let cduce2ocaml_tuple_3 fa fb fc = function
  | Value.Pair ( a, Value.Pair ( b, c ) ) -> fa a, fb b, fc c
  | _ -> assert false

let cduce2ocaml_tuple_4 fa fb fc fd = function
  | Value.Pair ( a, Value.Pair ( b, Value.Pair ( c, d ) ) ) ->
      fa a, fb b, fc c, fd d
  | _ -> assert false