aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/qparser/parser.mly58
-rw-r--r--lib/qparser/qsp_expression.mly4
-rw-r--r--lib/qparser/qsp_instruction.mly22
-rw-r--r--lib/syntax/S.ml95
-rw-r--r--lib/syntax/dead_end.ml10
-rw-r--r--lib/syntax/default.ml26
-rw-r--r--lib/syntax/tree.ml124
-rw-r--r--lib/syntax/tree.mli8
-rw-r--r--lib/syntax/type_of.ml105
9 files changed, 281 insertions, 171 deletions
diff --git a/lib/qparser/parser.mly b/lib/qparser/parser.mly
index 84c1af8..8547e17 100644
--- a/lib/qparser/parser.mly
+++ b/lib/qparser/parser.mly
@@ -1,6 +1,23 @@
%{
module T = Qsp_syntax.T
+ open StdLabels
+
+ type action_block =
+ { loc : Qsp_syntax.S.pos
+ ; expression :
+ Qsp_syntax.Report.t list
+ -> Analyzer.Expression.t' * Qsp_syntax.Report.t list
+ ; body : Analyzer.Instruction.t Qsp_syntax.S.repr list
+ ; pos : Qsp_syntax.S.pos
+ ; else_ : (
+ ( Analyzer.Instruction.clause list
+ * Analyzer.Instruction.t Qsp_syntax.S.repr list
+ ) option )
+ }
+
+ module Helper = Qsp_syntax.S.Helper(Analyzer.Expression)
+ module HelperI = Qsp_syntax.S.Helper(Analyzer.Instruction)
%}
%parameter<Analyzer: Qsp_syntax.S.Analyzer>
@@ -13,10 +30,11 @@ main:
| before_location*
LOCATION_START
EOL+
- expressions = line_statement*
+ instructions = line_statement*
LOCATION_END
{
- Analyzer.Location.location $loc expressions
+ let instructions = List.map instructions ~f:(HelperI.v) in
+ Analyzer.Location.location $loc instructions
}
before_location:
@@ -31,20 +49,20 @@ line_statement:
| s = terminated(inline_action, line_sep)
{ s }
| a = action_bloc(IF, elif_else_body)
- { let loc, expression, statements, loc_s, body = a in
- let elifs, else_ = match body with
+ { let {loc; expression; body; pos; else_ } = a in
+ let elifs, else_ = match else_ with
| None -> [], []
| Some (elifs, else_) -> (elifs, else_)
in
Analyzer.Instruction.if_
loc
- (loc_s, expression, statements)
+ (pos, expression, body)
~elifs
~else_
}
| a = action_bloc(ACT, empty_body)
- { let loc, label, statements, _, _ = a in
- Analyzer.Instruction.act loc ~label statements
+ { let {loc; expression; body; _} = a in
+ Analyzer.Instruction.act loc ~label:expression body
}
(** Represent an instruction which can either be on a single line,
@@ -58,7 +76,31 @@ line_statement:
b = BODY
END TOKEN?
line_sep
- { $loc, e, s, $loc(s), b }
+ {
+ let expression = Helper.v e in
+ let else_ = match b with
+ | None -> None
+ | Some (elifs, else_) ->
+ let elifs = begin match elifs with
+ | [] -> []
+ | _ ->
+ List.map elifs
+ ~f:(fun ((pos:Qsp_syntax.S.pos), e, instructions) ->
+ let e = Helper.v e in
+ (pos, e, instructions)
+ )
+
+ end in
+ Some (elifs, else_)
+ in
+
+ { loc = $loc
+ ; expression
+ ; body = s
+ ; else_ = else_
+ ; pos = $loc(s)
+ }
+ }
empty_body:
| { None }
diff --git a/lib/qparser/qsp_expression.mly b/lib/qparser/qsp_expression.mly
index 06cfadd..799be31 100644
--- a/lib/qparser/qsp_expression.mly
+++ b/lib/qparser/qsp_expression.mly
@@ -20,7 +20,7 @@
*)
%inline argument(X):
- | a = delimited(L_PAREN, arguments(X), R_PAREN) { a }
+ | a = delimited(L_PAREN, arguments(X), R_PAREN) { a }
| a = X { [ a ] }
(** Declare an expression *)
@@ -82,5 +82,5 @@ unary_operator:
(* No declaration, consider index at 0 *)
None
| Some other -> other in
- Analyzer.Expression.{ pos = $loc ; name ; index }
+ Qsp_syntax.S.{ pos = $loc ; name ; index }
}
diff --git a/lib/qparser/qsp_instruction.mly b/lib/qparser/qsp_instruction.mly
index bc1ca37..fe8a51a 100644
--- a/lib/qparser/qsp_instruction.mly
+++ b/lib/qparser/qsp_instruction.mly
@@ -4,6 +4,8 @@ optionnal_delimited(opening, X, closing):
| v = delimited(opening, X, closing) { v }
| v = X { v }
+(* Redefine the arguments from expression here because we accept
+ * values without parens. *)
argument(X):
| a = optionnal_delimited(L_PAREN, arguments(X), R_PAREN) { a }
| a = X { [ a ] }
@@ -16,44 +18,47 @@ argument(X):
%public inline_action:
| a = onliner(ACT)
{ let loc, label, statements, _, _ = a in
+ let label = Helper.v label in
Analyzer.Instruction.act loc ~label statements
}
| a = onliner(IF)
else_opt = preceded(ELSE, instruction)?
- { let loc, expression, statements, loc_s, _body = a in
+ { let loc, expr, statements, loc_s, _body = a in
let elifs = []
and else_ = Option.to_list else_opt in
Analyzer.Instruction.if_
loc
- (loc_s, expression, statements)
+ (loc_s, Helper.v expr, statements)
~elifs
~else_
}
| a = onliner(IF)
else_= preceded(ELSE, inline_action)
- { let loc, expression, statements, loc_s, _body = a in
+ { let loc, expr, statements, loc_s, _body = a in
let elifs = []
and else_ = [ else_ ] in
+
Analyzer.Instruction.if_
loc
- (loc_s, expression, statements)
+ (loc_s, Helper.v expr, statements)
~elifs
~else_
}
single_instruction:
| expr = expression
{
+ let expr = Helper.v expr in
Analyzer.Instruction.expression expr
}
| e = let_assignation { e }
| k = keyword
- arg = argument(expression)
+ args = argument(expression)
{
- Analyzer.Instruction.call $loc k arg
+ let args = List.map args ~f:(Helper.v) in
+ Analyzer.Instruction.call $loc k args
}
keyword:
- (*| STAR k = KEYWORD { "*" ^ k }*)
| k = KEYWORD { k }
let_assignation:
@@ -62,6 +67,9 @@ let_assignation:
op = assignation_operator
value = expression
{
+ let variable = Helper.variable variable
+ and value = Helper.v value in
+
Analyzer.Instruction.assign $loc variable op value
}
diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml
index 6bdbc9d..3b24aff 100644
--- a/lib/syntax/S.ml
+++ b/lib/syntax/S.ml
@@ -13,64 +13,79 @@
*)
+type 'a repr = Report.t list -> 'a * Report.t list
+
type pos = Lexing.position * Lexing.position
+(** Starting and ending position for the given location *)
+
type ('a, 'b) variable = { pos : 'a; name : string; index : 'b option }
+(** Describe a variable, using the name in capitalized text, and an optionnal
+ index.
+
+ If missing, the index should be considered as [0].*)
(** Represent the evaluation over an expression *)
module type Expression = sig
- type 'a obs
type t
- type repr = Report.t list -> t * Report.t list
-
- type variable = { pos : pos; name : string; index : repr option }
- (**
- Describe a variable, using the name in capitalized text, and an optionnal
- index.
+ (** Internal type used in the evaluation *)
- If missing, the index should be considered as [0].
- *)
+ type t'
+ (** External type used outside of the module *)
- val ident : variable -> repr
+ val v : t * Report.t list -> t' * Report.t list
+ val ident : (pos, t repr) variable -> t repr
(*
Basic values, text, number…
*)
- val integer : pos -> string -> repr
- val literal : pos -> string -> repr
+ val integer : pos -> string -> t repr
+ val literal : pos -> string -> t repr
- val function_ : pos -> T.function_ -> repr list -> repr
+ val function_ : pos -> T.function_ -> t repr list -> t repr
(** Call a function. The functions list is hardcoded in lib/lexer.mll *)
- val uoperator : pos -> T.uoperator -> repr -> repr
+ val uoperator : pos -> T.uoperator -> t repr -> t repr
(** Unary operator like [-123] or [+'Text']*)
- val boperator : pos -> T.boperator -> repr -> repr -> repr
+ val boperator : pos -> T.boperator -> t repr -> t repr -> t repr
(** Binary operator, for a comparaison, or an operation *)
end
module type Instruction = sig
- type repr
+ type t
+ (** Internal type used in the evaluation *)
+
+ type t'
+ (** External type used outside of the module *)
+
+ val v : t * Report.t list -> t' * Report.t list
+
type expression
- type variable
- val call : pos -> T.keywords -> expression list -> repr
+ val call : pos -> T.keywords -> expression list -> t repr
(** Call for an instruction like [GT] or [*CLR] *)
- val location : pos -> string -> repr
+ val location : pos -> string -> t repr
(** Label for a loop *)
- val comment : pos -> repr
+ val comment : pos -> t repr
(** Comment *)
- val expression : expression -> repr
+ val expression : expression -> t repr
(** Raw expression *)
- type clause = pos * expression * repr list
+ type clause = pos * expression * t repr list
- val if_ : pos -> clause -> elifs:clause list -> else_:repr list -> repr
- val act : pos -> label:expression -> repr list -> repr
- val assign : pos -> variable -> T.assignation_operator -> expression -> repr
+ val if_ : pos -> clause -> elifs:clause list -> else_:t repr list -> t repr
+ val act : pos -> label:expression -> t repr list -> t repr
+
+ val assign :
+ pos ->
+ (pos, expression) variable ->
+ T.assignation_operator ->
+ expression ->
+ t repr
end
module type Location = sig
@@ -82,11 +97,31 @@ end
module type Analyzer = sig
module Expression : Expression
+ module Instruction : Instruction with type expression = Expression.t' repr
+ module Location : Location with type instruction = Instruction.t' repr
+end
+
+(** Helper module used in order to convert elements from the differents
+ representation levels *)
+module Helper (E : sig
+ type t
+ (** Internal type used in the evaluation *)
+
+ type t'
+ (** External type used outside of the module *)
+
+ val v : t * Report.t list -> t' * Report.t list
+end) : sig
+ val v : E.t repr -> E.t' repr
- module Instruction :
- Instruction
- with type expression = Expression.repr
- and type variable = Expression.variable
+ val variable : (pos, E.t repr) variable -> (pos, E.t' repr) variable
+ (** Convert a variable from the [Expression.t] into [Expression.t'] *)
+end = struct
+ let v : E.t repr -> E.t' repr =
+ fun v report ->
+ let value, report = v report in
+ E.v (value, report)
- module Location : Location with type instruction = Instruction.repr
+ let variable : (pos, E.t repr) variable -> (pos, E.t' repr) variable =
+ fun variable -> { variable with index = Option.map v variable.index }
end
diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml
index 78eadda..bb78263 100644
--- a/lib/syntax/dead_end.ml
+++ b/lib/syntax/dead_end.ml
@@ -6,9 +6,8 @@ type ('a, 'b) variable = { pos : 'a; name : string; index : 'b option }
module Expression = Default.Expression
module Instruction = struct
+ type expression = Default.Expression.t' S.repr
type repr = unit
- type expression = Expression.repr
- type variable = Expression.variable
(** Call for an instruction like [GT] or [*CLR] *)
let call : pos -> string -> expression list -> repr = fun _ _ _ -> ()
@@ -35,7 +34,12 @@ module Instruction = struct
ignore label;
()
- let assign : pos -> variable -> T.assignation_operator -> expression -> repr =
+ let assign :
+ pos ->
+ (S.pos, expression) S.variable ->
+ T.assignation_operator ->
+ expression ->
+ repr =
fun _ _ _ _ -> ()
end
diff --git a/lib/syntax/default.ml b/lib/syntax/default.ml
index 9c5073c..eed7f2b 100644
--- a/lib/syntax/default.ml
+++ b/lib/syntax/default.ml
@@ -3,14 +3,7 @@
This module is expected to be used when you only need to implement an analyze
over a limited part of the whole syntax. *)
-type pos = Lexing.position * Lexing.position
-type ('a, 'b) variable = { pos : 'a; name : string; index : 'b option }
-
module Expression = struct
- type 'a obs
- type repr = unit
-
- type variable
(**
Describe a variable, using the name in capitalized text, and an optionnal
index.
@@ -18,21 +11,28 @@ module Expression = struct
If missing, the index should be considered as [0].
*)
- let ident : variable -> repr = fun _ -> ()
+ type t = unit
+ type t' = unit
+
+ let ident : (S.pos, t S.repr) S.variable -> t S.repr =
+ fun _ report -> ((), report)
(*
Basic values, text, number…
*)
- let integer : pos -> string -> repr = fun _ _ -> ()
- let literal : pos -> string -> repr = fun _ _ -> ()
+ let integer : S.pos -> string -> t S.repr = fun _ _ report -> ((), report)
+ let literal : S.pos -> string -> t S.repr = fun _ _ report -> ((), report)
(** Call a function. The functions list is hardcoded in lib/lexer.mll *)
- let function_ : pos -> T.function_ -> repr list -> repr = fun _ _ _ -> ()
+ let function_ : S.pos -> T.function_ -> t S.repr list -> t S.repr =
+ fun _ _ _ report -> ((), report)
(** Unary operator like [-123] or [+'Text']*)
- let uoperator : pos -> T.uoperator -> repr -> repr = fun _ _ _ -> ()
+ let uoperator : S.pos -> T.uoperator -> t S.repr -> t S.repr =
+ fun _ _ _ report -> ((), report)
(** Binary operator, for a comparaison, or an operation *)
- let boperator : pos -> T.boperator -> repr -> repr -> repr = fun _ _ _ _ -> ()
+ let boperator : S.pos -> T.boperator -> t S.repr -> t S.repr -> t S.repr =
+ fun _ _ _ _ report -> ((), report)
end
diff --git a/lib/syntax/tree.ml b/lib/syntax/tree.ml
index 51033a1..02c6b36 100644
--- a/lib/syntax/tree.ml
+++ b/lib/syntax/tree.ml
@@ -1,10 +1,6 @@
open StdLabels
-type pos = Lexing.position * Lexing.position
-
module Ast = struct
- type nonrec pos = pos
-
type 'a variable = { pos : 'a; name : string; index : 'a expression option }
[@@deriving eq, show]
@@ -36,31 +32,34 @@ module Ast = struct
end
(** Default implementation for the expression *)
-module Expression : S.Expression with type t = pos Ast.expression = struct
- type 'a obs
- type t = pos Ast.expression
- type repr = Report.t list -> t * Report.t list
- type variable = { pos : pos; name : string; index : repr option }
+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 : pos -> string -> repr = fun pos i r -> (Ast.Integer (pos, i), r)
- let literal : pos -> string -> repr = fun pos l r -> (Ast.Literal (pos, l), r)
+ let integer : S.pos -> string -> t S.repr =
+ fun pos i r -> (Ast.Integer (pos, i), r)
- let function_ : pos -> T.function_ -> repr list -> repr =
+ 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 : pos -> T.uoperator -> repr -> repr =
+ 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 : pos -> T.boperator -> repr -> repr -> repr =
+ 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 : variable -> repr =
+ 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)
@@ -68,50 +67,67 @@ end
module Instruction :
S.Instruction
- with type expression = Expression.repr
- and type repr = pos Ast.statement
- and type variable = Expression.variable = struct
- type repr = pos Ast.statement
- type expression = Expression.repr
- type variable = Expression.variable
-
- let call : pos -> T.keywords -> expression list -> repr =
- fun pos name args ->
- let args = List.map ~f:(fun f -> fst (f [])) args in
- Ast.Call (pos, name, args)
-
- let location : pos -> string -> repr =
- fun loc label -> Ast.Location (loc, label)
+ 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 comment : pos -> repr = fun pos -> Ast.Comment pos
+ let v = Fun.id
- let expression : expression -> repr =
- fun expr -> Ast.Expression (fst (expr []))
+ type expression = Expression.t' S.repr
- type clause = pos * expression * repr list
-
- let if_ : pos -> clause -> elifs:clause list -> else_:repr list -> repr =
- fun pos predicate ~elifs ~else_ ->
- let clause (pos, expr, repr) = (pos, fst (expr []), repr) in
- let elifs = List.map ~f:clause elifs in
-
- Ast.If { loc = pos; then_ = clause predicate; elifs; else_ }
-
- let act : pos -> label:expression -> repr list -> repr =
- fun pos ~label statements ->
- let label = fst (label []) in
- Ast.Act { loc = pos; label; statements }
-
- let assign : pos -> variable -> T.assignation_operator -> expression -> repr =
- fun pos_loc { pos; name; index } op expr ->
- let index = Option.map (fun i -> fst (i [])) index
- and expr = fst (expr []) in
- Ast.Declaration (pos_loc, { pos; name; index }, op, expr)
+ 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)
+
+ type clause = S.pos * expression * t S.repr list
+
+ let if_ :
+ S.pos -> clause -> elifs:clause list -> else_:t S.repr list -> 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_ = List.map ~f:(fun instr -> fst @@ instr []) else_ 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 = pos Ast.statement
- type repr = pos * instruction list
+ type instruction = S.pos Ast.statement S.repr
+ type repr = S.pos * S.pos Ast.statement list
- let location : pos -> instruction list -> repr = fun pos block -> (pos, block)
+ let location : S.pos -> instruction list -> repr =
+ fun pos block ->
+ let block = List.map block ~f:(fun b -> fst @@ b []) in
+ (pos, block)
end
diff --git a/lib/syntax/tree.mli b/lib/syntax/tree.mli
index c54a9ff..c16a02a 100644
--- a/lib/syntax/tree.mli
+++ b/lib/syntax/tree.mli
@@ -7,8 +7,6 @@
(** This module is the result of the evaluation. *)
module Ast : sig
- type pos = Lexing.position * Lexing.position
-
type 'a variable = { pos : 'a; name : string; index : 'a expression option }
[@@deriving eq, show]
(** A variable, used both in an expression (reference) or in a statement
@@ -46,6 +44,6 @@ end
include
S.Analyzer
- with type Expression.t = Ast.pos Ast.expression
- and type Instruction.repr = Ast.pos Ast.statement
- and type Location.repr = Ast.pos * Ast.pos Ast.statement list
+ with type Expression.t' = S.pos Ast.expression
+ and type Instruction.t' = S.pos Ast.statement
+ and type Location.repr = S.pos * S.pos Ast.statement list
diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml
index 1cefc22..83258cc 100644
--- a/lib/syntax/type_of.ml
+++ b/lib/syntax/type_of.ml
@@ -1,13 +1,10 @@
open StdLabels
-type pos = Lexing.position * Lexing.position
-(** Extract the type for expression *)
-
module Helper = struct
type t = Integer | Bool | String | Any
[@@deriving show { with_path = false }]
- type argument_repr = { pos : pos; t : t }
+ type argument_repr = { pos : S.pos; t : t }
type dyn_type = t -> t
(** Dynamic type is a type unknown during the code.
@@ -81,7 +78,7 @@ module Helper = struct
let compare_args :
?strict:bool ->
?level:Report.level ->
- pos ->
+ S.pos ->
argument list ->
argument_repr list ->
Report.t list ->
@@ -109,16 +106,10 @@ module Helper = struct
end
module Expression = struct
- type 'a obs
- type t = { result : Helper.t; pos : pos; empty : bool }
-
- type repr = Report.t list -> t * Report.t list
- (** The type repr is a function accepting the report as a first argement.
- When the report is given, it will be reported into the tree and collected
- in bottom-top.
- *)
+ type t = { result : Helper.t; pos : S.pos; empty : bool }
+ type t' = t
- type variable = { pos : pos; name : string; index : repr option }
+ let v t = t
let arg_of_repr : t -> Helper.argument_repr =
fun { result; pos; empty } ->
@@ -126,14 +117,14 @@ module Expression = struct
{ pos; t = result }
(** The variable has type string when starting with a '$' *)
- let ident : variable -> repr =
+ let ident : (S.pos, t S.repr) S.variable -> t S.repr =
fun var report ->
let empty = false in
match var.name.[0] with
| '$' -> ({ result = String; pos = var.pos; empty }, report)
| _ -> ({ result = Integer; pos = var.pos; empty }, report)
- let integer : pos -> string -> repr =
+ let integer : S.pos -> string -> t S.repr =
fun pos value report ->
let empty =
match int_of_string_opt value with Some 0 -> true | _ -> false
@@ -141,12 +132,12 @@ module Expression = struct
({ result = Integer; pos; empty }, report)
- let literal : pos -> string -> repr =
+ let literal : S.pos -> string -> t S.repr =
fun pos value report ->
let empty = String.equal String.empty value in
({ result = String; pos; empty }, report)
- let function_ : pos -> T.function_ -> repr list -> repr =
+ let function_ : S.pos -> T.function_ -> t S.repr list -> t S.repr =
fun pos function_ params _acc ->
(* Accumulate the expressions and get the results, the report is given in
the differents arguments, and we build a list with the type of the
@@ -237,7 +228,7 @@ module Expression = struct
({ result = Integer; pos; empty = false }, report)
(** Unary operator like [-123] or [+'Text']*)
- let uoperator : pos -> T.uoperator -> repr -> repr =
+ let uoperator : S.pos -> T.uoperator -> t S.repr -> t S.repr =
fun pos operator t1 report ->
let t, report = t1 report in
match operator with
@@ -248,7 +239,7 @@ module Expression = struct
let report = Helper.compare_args pos expected types report in
({ result = Integer; pos; empty = false }, report)
- let boperator : pos -> T.boperator -> repr -> repr -> repr =
+ let boperator : S.pos -> T.boperator -> t S.repr -> t S.repr -> t S.repr =
fun pos operator t1 t2 report ->
let t1, report = t1 report in
let t2, report = t2 report in
@@ -292,61 +283,72 @@ module Expression = struct
end
module Instruction = struct
- type repr = Report.t list -> Report.t list
- type expression = Expression.repr
- type variable = Expression.variable
+ type t = unit
+ type t' = unit
+
+ let v = Fun.id
+
+ type expression = Expression.t' S.repr
(** Call for an instruction like [GT] or [*CLR] *)
- let call : pos -> T.keywords -> expression list -> repr =
+ let call : S.pos -> T.keywords -> expression list -> t S.repr =
fun _pos _ expressions report ->
- List.fold_left expressions ~init:report ~f:(fun report expression ->
+ List.fold_left expressions ~init:((), report)
+ ~f:(fun ((), report) expression ->
let result, report = expression report in
ignore result;
- report)
+ ((), report))
- let location : pos -> string -> repr = fun _pos _ report -> report
+ let location : S.pos -> string -> t S.repr = fun _pos _ report -> ((), report)
(** Comment *)
- let comment : pos -> repr = fun _pos report -> report
+ let comment : S.pos -> t S.repr = fun _pos report -> ((), report)
(** Raw expression *)
- let expression : expression -> repr =
- fun expression report -> snd (expression report)
+ let expression : expression -> t S.repr =
+ fun expression report -> ((), snd (expression report))
- type clause = pos * expression * repr list
+ type clause = S.pos * expression * t S.repr list
- let if_ : pos -> clause -> elifs:clause list -> else_:repr list -> repr =
+ let if_ :
+ S.pos -> clause -> elifs:clause list -> else_:t S.repr list -> t S.repr =
fun _pos clause ~elifs ~else_ report ->
(* Helper function *)
- let fold_clause report (_pos, expr, instructions) : Report.t list =
+ let fold_clause : t * Report.t list -> clause -> t * Report.t list =
+ fun ((), report) (_pos, expr, instructions) ->
let result, report = expr report in
let report =
Helper.compare Helper.Bool (Expression.arg_of_repr result) report
in
- List.fold_left instructions ~init:report ~f:(fun report instruction ->
- instruction report)
+ List.fold_left instructions ~init:((), report)
+ ~f:(fun ((), report) instruction -> instruction report)
in
(* Traverse the whole block recursively *)
- let report = fold_clause report clause in
+ let report = fold_clause ((), report) clause in
let report = List.fold_left elifs ~f:fold_clause ~init:report in
- List.fold_left else_ ~init:report ~f:(fun report instruction ->
+ List.fold_left else_ ~init:report ~f:(fun ((), report) instruction ->
instruction report)
- let act : pos -> label:expression -> repr list -> repr =
+ let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
fun _pos ~label instructions report ->
let result, report = label report in
let report =
Helper.compare Helper.String (Expression.arg_of_repr result) report
in
- List.fold_left instructions ~init:report ~f:(fun report instruction ->
- instruction report)
-
- let assign : pos -> variable -> T.assignation_operator -> expression -> repr =
+ List.fold_left instructions ~init:((), report)
+ ~f:(fun ((), report) instruction -> instruction report)
+
+ let assign :
+ S.pos ->
+ (S.pos, expression) S.variable ->
+ T.assignation_operator ->
+ expression ->
+ t S.repr =
fun pos variable _ expression report ->
let right_expression, report = expression report in
match right_expression.empty with
- | true -> report
+ | true -> ((), report)
| false ->
let expr1, report = Expression.ident variable report in
let op1 = Expression.arg_of_repr expr1 in
@@ -355,15 +357,20 @@ module Instruction = struct
let d = Helper.dyn_type () in
(* Every part of the assignation should be the same type *)
let expected = Helper.[ Dynamic d; Dynamic d ] in
- Helper.compare_args ~level:Report.Debug pos expected [ op1; op2 ] report
+ ( (),
+ Helper.compare_args ~level:Report.Debug pos expected [ op1; op2 ]
+ report )
end
module Location = struct
- type repr = Instruction.repr
- type instruction = Instruction.repr
+ type repr = Report.t list -> Report.t list
+ type instruction = Instruction.t S.repr
- let location : pos -> instruction list -> repr =
+ let location : S.pos -> instruction list -> repr =
fun _pos instructions report ->
- List.fold_left instructions ~init:report ~f:(fun report instruction ->
- instruction report)
+ let (), report =
+ List.fold_left instructions ~init:((), report)
+ ~f:(fun ((), report) instruction -> instruction report)
+ in
+ report
end