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
|
open StdLabels
let identifier = "tree"
let description = "Build the AST"
let active = ref true
module Ast = struct
type 'a literal = 'a T.literal = Text of string | Expression of 'a
[@@deriving eq, show]
type 'a variable = { pos : 'a; name : string; index : 'a expression option }
[@@deriving eq, show]
and 'a expression =
| Integer of 'a * string
| Literal of 'a * 'a expression literal list
| 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 -> t' = fun t -> t
let integer : S.pos -> string -> t = fun pos i -> Ast.Integer (pos, i)
let literal : S.pos -> t T.literal list -> t =
fun pos l -> Ast.Literal (pos, l)
let function_ : S.pos -> T.function_ -> t list -> t =
fun pos name args -> Ast.Function (pos, name, args)
let uoperator : S.pos -> T.uoperator -> t -> t =
fun pos op expression -> Ast.Op (pos, op, expression)
let boperator : S.pos -> T.boperator -> t -> t -> t =
fun pos op op1 op2 ->
let op1 = op1 and op2 = op2 in
Ast.BinaryOp (pos, op, op1, op2)
let ident : (S.pos, t) S.variable -> t =
fun { pos; name; index } ->
let index = Option.map (fun i -> i) index in
Ast.Ident { pos; name; index }
end
module Instruction :
S.Instruction
with type expression = Expression.t'
and type t' = S.pos Ast.statement = struct
type t = S.pos Ast.statement
type t' = t
let v : t -> t' = fun t -> t
type expression = Expression.t'
let call : S.pos -> T.keywords -> expression list -> t =
fun pos name args -> Ast.Call (pos, name, args)
let location : S.pos -> string -> t =
fun loc label -> Ast.Location (loc, label)
let comment : S.pos -> t = fun pos -> Ast.Comment pos
let expression : expression -> t = fun expr -> Ast.Expression expr
let if_ :
S.pos ->
(expression, t) S.clause ->
elifs:(expression, t) S.clause list ->
else_:(S.pos * t list) option ->
t =
fun pos predicate ~elifs ~else_ ->
let clause (pos, expr, repr) = (pos, expr, repr) in
let elifs = List.map ~f:clause elifs
and else_ =
match else_ with None -> [] | Some (_, instructions) -> instructions
in
Ast.If { loc = pos; then_ = clause predicate; elifs; else_ }
let act : S.pos -> label:expression -> t list -> t =
fun pos ~label statements -> Ast.Act { loc = pos; label; statements }
let assign :
S.pos ->
(S.pos, expression) S.variable ->
T.assignation_operator ->
expression ->
t =
fun pos_loc { pos; name; index } op expr ->
(*let index = Option.map (fun i -> fst @@ Expression.observe (i [])) index*)
Ast.Declaration (pos_loc, { pos; name; index }, op, expr)
end
module Location = struct
type instruction = Instruction.t'
type t = S.pos * S.pos Ast.statement list
let v _ = []
let location : S.pos -> instruction list -> t = fun pos block -> (pos, block)
end
|
