1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
(** Build a module with the result from another one module *)
open StdLabels
module S = Qsp_syntax.S
module T = Qsp_syntax.T
(** Make a module lazy *)
module Lazier (E : S.Expression) :
S.Expression with type t' = E.t' Lazy.t and type t = E.t Lazy.t = struct
type t = E.t Lazy.t
type t' = E.t' Lazy.t
let v : E.t Lazy.t -> E.t' Lazy.t = Lazy.map E.v
let integer : S.pos -> string -> t = fun pos i -> lazy (E.integer pos i)
let ident : (S.pos, t) S.variable -> t =
fun { pos; name : string; index : t option } ->
lazy (E.ident { pos; name; index = Option.map Lazy.force index })
let literal : S.pos -> t T.literal list -> t =
fun pos litts ->
lazy
(let e_litts = List.map litts ~f:(T.map_litteral ~f:Lazy.force) in
E.literal pos e_litts)
let function_ : S.pos -> T.function_ -> t list -> t =
fun pos f e ->
lazy
(let e' = List.map ~f:Lazy.force e in
E.function_ pos f e')
let uoperator : S.pos -> T.uoperator -> t -> t =
fun pos op t ->
let t' = lazy (E.uoperator pos op (Lazy.force t)) in
t'
let boperator : S.pos -> T.boperator -> t -> t -> t =
fun pos op t1 t2 ->
let t' = lazy (E.boperator pos op (Lazy.force t1) (Lazy.force t2)) in
t'
end
(** Build an expression module with the result from another expression. The
signature of the fuctions is a bit different, as they all receive the result
from the previous evaluated element in argument. *)
module Expression (E : S.Expression) = struct
module type SIG = sig
type t
type t'
(* Override the type [t] in the definition of all the functions. The
signatures differs a bit from the standard signature as they get the
result from E.t in last argument *)
val ident : (S.pos, E.t' Lazy.t * t) S.variable -> E.t' Lazy.t -> t
val integer : S.pos -> string -> E.t' Lazy.t -> t
val literal : S.pos -> (E.t' Lazy.t * t) T.literal list -> E.t' Lazy.t -> t
val function_ :
S.pos -> T.function_ -> (E.t' Lazy.t * t) list -> E.t' Lazy.t -> t
val uoperator : S.pos -> T.uoperator -> E.t' Lazy.t * t -> E.t' Lazy.t -> t
val boperator :
S.pos ->
T.boperator ->
E.t' Lazy.t * t ->
E.t' Lazy.t * t ->
E.t' Lazy.t ->
t
val v : E.t' Lazy.t * t -> t'
(** Convert from the internal representation to the external one. *)
end
(* Create a lazy version of the module *)
module E = Lazier (E)
module Make (M : SIG) : S.Expression with type t' = M.t' = struct
type t = E.t * M.t
type t' = M.t'
let v' : E.t -> E.t' = E.v
let v : t -> t' = fun (type_of, v) -> M.v (v' type_of, v)
let ident : (S.pos, t) S.variable -> t =
fun { pos; name : string; index : t option } ->
let t' = E.ident { pos; name; index = Option.map fst index } in
let index' = Option.map (fun (e, m) -> (v' e, m)) index in
(t', M.ident { pos; name; index = index' } (v' t'))
let integer : S.pos -> string -> t =
fun pos i ->
let t' = E.integer pos i in
(t', M.integer pos i (v' t'))
let literal : S.pos -> t T.literal list -> t =
fun pos litts ->
let litts' =
List.map litts ~f:(T.map_litteral ~f:(fun (e, m) -> (v' e, m)))
in
let t' =
let e_litts = List.map litts ~f:(T.map_litteral ~f:fst) in
E.literal pos e_litts
in
(t', M.literal pos litts' (v' t'))
let function_ : S.pos -> T.function_ -> t list -> t =
fun pos f expressions ->
let e = List.map ~f:fst expressions
and expressions' = List.map ~f:(fun (e, m) -> (v' e, m)) expressions in
let t' = E.function_ pos f e in
(t', M.function_ pos f expressions' (v' t'))
let uoperator : S.pos -> T.uoperator -> t -> t =
fun pos op (t, expr) ->
let t' = E.uoperator pos op t in
(t', M.uoperator pos op (v' t, expr) (v' t'))
let boperator : S.pos -> T.boperator -> t -> t -> t =
fun pos op (t1, expr1) (t2, expr2) ->
let t' = E.boperator pos op t1 t2 in
(t', M.boperator pos op (v' t1, expr1) (v' t2, expr2) (v' t'))
end
end
module TypeBuilder = Expression (Get_type)
(** Builder adding the type for the expression *)
|
