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
|
open StdLabels
let identifier = "tree"
let description = "Build the AST"
let active = ref true
type context = unit
let initialize = Fun.id
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 : unit -> S.pos -> instruction list -> t =
fun () pos block -> (pos, block)
end
|
