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
131
132
133
134
135
136
137
138
139
140
|
open StdLabels
module Ast = struct
type 'a variable = { pos : 'a; name : string; index : 'a expression option }
[@@deriving eq, show]
and 'a expression =
| Integer of 'a * string
| Literal of 'a * string
| Ident of 'a variable
| BinaryOp of 'a * T.boperator * 'a expression * 'a expression
| Op of 'a * T.uoperator * 'a expression
| Function of 'a * T.function_ * 'a expression list
[@@deriving eq, show]
and 'a condition = 'a * 'a expression * 'a statement list
and 'a statement =
| If of {
loc : 'a;
then_ : 'a condition;
elifs : 'a condition list;
else_ : 'a statement list;
}
| Act of { loc : 'a; label : 'a expression; statements : 'a statement list }
| Declaration of ('a * 'a variable * T.assignation_operator * 'a expression)
| Expression of 'a expression
| Comment of 'a
| Call of 'a * T.keywords * 'a expression list
| Location of 'a * string
[@@deriving eq, show]
end
(** Default implementation for the expression *)
module Expression : S.Expression with type t' = S.pos Ast.expression = struct
type t = S.pos Ast.expression
type t' = t
let v : t * Report.t list -> t' * Report.t list = fun (t, r) -> (t, r)
let integer : S.pos -> string -> t S.repr =
fun pos i r -> (Ast.Integer (pos, i), r)
let literal : S.pos -> string -> t S.repr =
fun pos l r -> (Ast.Literal (pos, l), r)
let function_ : S.pos -> T.function_ -> t S.repr list -> t S.repr =
fun pos name args r ->
let args = List.map ~f:(fun f -> fst (f r)) args in
(Ast.Function (pos, name, args), r)
let uoperator : S.pos -> T.uoperator -> t S.repr -> t S.repr =
fun pos op expression r ->
let expression = fst (expression r) in
(Ast.Op (pos, op, expression), r)
let boperator : S.pos -> T.boperator -> t S.repr -> t S.repr -> t S.repr =
fun pos op op1 op2 r ->
let op1 = fst (op1 r) and op2 = fst (op2 r) in
(Ast.BinaryOp (pos, op, op1, op2), r)
let ident : (S.pos, t S.repr) S.variable -> t S.repr =
fun { pos; name; index } r ->
let index = Option.map (fun i -> fst (i r)) index in
(Ast.Ident { pos; name; index }, r)
end
module Instruction :
S.Instruction
with type expression = Expression.t' S.repr
and type t' = S.pos Ast.statement = struct
type t = S.pos Ast.statement
type t' = t
let v = Fun.id
type expression = Expression.t' S.repr
let call : S.pos -> T.keywords -> expression list -> t S.repr =
fun pos name args report ->
let args = List.map ~f:(fun f -> fst (f [])) args in
(Ast.Call (pos, name, args), report)
let location : S.pos -> string -> t S.repr =
fun loc label report -> (Ast.Location (loc, label), report)
let comment : S.pos -> t S.repr = fun pos report -> (Ast.Comment pos, report)
let expression : expression -> t S.repr =
fun expr report -> (Ast.Expression (fst (expr [])), report)
let if_ :
S.pos ->
(expression, t) S.clause ->
elifs:(expression, t) S.clause list ->
else_:(S.pos * t S.repr list) option ->
t S.repr =
fun pos predicate ~elifs ~else_ report ->
let clause (pos, expr, repr) =
let repr = List.map ~f:(fun instr -> fst @@ instr []) repr in
(pos, fst @@ expr [], repr)
in
let elifs = List.map ~f:clause elifs
and else_ =
match else_ with
| None -> []
| Some (_, instructions) ->
List.map ~f:(fun instr -> fst @@ instr []) instructions
in
(Ast.If { loc = pos; then_ = clause predicate; elifs; else_ }, report)
let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
fun pos ~label statements report ->
let label = fst (label [])
and statements = List.map ~f:(fun instr -> fst @@ instr []) statements in
(Ast.Act { loc = pos; label; statements }, report)
let assign :
S.pos ->
(S.pos, expression) S.variable ->
T.assignation_operator ->
expression ->
t S.repr =
fun pos_loc { pos; name; index } op expr report ->
(*let index = Option.map (fun i -> fst @@ Expression.observe (i [])) index*)
let index = Option.map (fun f -> fst @@ f []) index in
let expr = fst (expr []) in
(Ast.Declaration (pos_loc, { pos; name; index }, op, expr), report)
end
module Location = struct
type instruction = S.pos Ast.statement
type t = S.pos * S.pos Ast.statement list
let location : S.pos -> instruction S.repr list -> t S.repr =
fun pos block _report ->
let block = List.map block ~f:(fun b -> fst @@ b []) in
((pos, block), [])
end
|
