aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChimrod <>2023-10-25 18:41:27 +0200
committerChimrod <>2023-10-25 20:33:12 +0200
commit319c1e4474f4fefde688720b78e8abf315513a32 (patch)
tree12908fcf3f2efdac2cd4cf8613807bc598d13bcb
parent2a2198e91063684a1b19974acc19c25b55266724 (diff)
Now I have the API I want. Everything is abstract in the type S.Analyzer
-rw-r--r--lib/qparser/analyzer.ml1
-rw-r--r--lib/qparser/parser.mly15
-rw-r--r--lib/qparser/qsp_instruction.mly14
-rw-r--r--lib/syntax/S.ml70
-rw-r--r--lib/syntax/check.ml396
-rw-r--r--lib/syntax/dead_end.ml91
-rw-r--r--lib/syntax/tree.ml65
-rw-r--r--lib/syntax/type_of.ml71
8 files changed, 267 insertions, 456 deletions
diff --git a/lib/qparser/analyzer.ml b/lib/qparser/analyzer.ml
index 06960f6..58a117f 100644
--- a/lib/qparser/analyzer.ml
+++ b/lib/qparser/analyzer.ml
@@ -36,7 +36,6 @@ let parse :
in
evaluation
- |> Result.map (fun e -> e [])
|> Result.map_error (fun e ->
let message =
match e.IncrementalParser.code with
diff --git a/lib/qparser/parser.mly b/lib/qparser/parser.mly
index d84e534..81b630a 100644
--- a/lib/qparser/parser.mly
+++ b/lib/qparser/parser.mly
@@ -5,21 +5,20 @@
type action_block =
{ loc : Qsp_syntax.S.pos
; expression :
- Analyzer.Expression.t' * Qsp_syntax.Report.t list
- ; body : Analyzer.Instruction.t Qsp_syntax.S.repr list
+ Analyzer.Expression.t'
+ ; body : Analyzer.Instruction.t list
; pos : Qsp_syntax.S.pos
; clauses : (
( (Analyzer.Instruction.expression, Analyzer.Instruction.t) Qsp_syntax.S.clause list
- * (Qsp_syntax.S.pos *Analyzer.Instruction.t Qsp_syntax.S.repr list) option
+ * (Qsp_syntax.S.pos * Analyzer.Instruction.t list) option
) option )
}
module Helper = Qsp_syntax.S.Helper(Analyzer.Expression)
- module HelperI = Qsp_syntax.S.Helper(Analyzer.Instruction)
%}
%parameter<Analyzer: Qsp_syntax.S.Analyzer>
-%start <(Analyzer.Location.t * Qsp_syntax.Report.t list) Qsp_syntax.S.repr>main
+%start <(Analyzer.Location.t * Qsp_syntax.Report.t list)>main
%on_error_reduce expression instruction unary_operator assignation_operator
%%
@@ -31,7 +30,7 @@ main:
instructions = line_statement*
LOCATION_END
{
- let instructions = List.map instructions ~f:(HelperI.v) in
+ let instructions = List.map instructions ~f:(Analyzer.Instruction.v) in
Analyzer.Location.location $loc instructions
}
@@ -75,7 +74,7 @@ line_statement:
END TOKEN?
line_sep
{
- let expression = Helper.v' e in
+ let expression = Analyzer.Expression.v e in
let clauses = match b with
| None -> None
| Some (elifs, clauses) ->
@@ -84,7 +83,7 @@ line_statement:
| _ ->
List.map elifs
~f:(fun ((pos:Qsp_syntax.S.pos), e, instructions) ->
- let e = Helper.v' e in
+ let e = Analyzer.Expression.v e in
(pos, e, instructions)
)
diff --git a/lib/qparser/qsp_instruction.mly b/lib/qparser/qsp_instruction.mly
index e8f5a77..b7d2558 100644
--- a/lib/qparser/qsp_instruction.mly
+++ b/lib/qparser/qsp_instruction.mly
@@ -18,7 +18,7 @@ argument(X):
%public inline_action:
| a = onliner(ACT)
{ let loc, label, statements, _, _ = a in
- let label = Helper.v' label in
+ let label = Analyzer.Expression.v label in
Analyzer.Instruction.act loc ~label statements
}
| a = onliner(IF)
@@ -30,7 +30,7 @@ argument(X):
| Some instructions -> Some ($loc(else_opt), [ instructions ]) in
Analyzer.Instruction.if_
loc
- (loc_s, Helper.v' expr, statements)
+ (loc_s, Analyzer.Expression.v expr, statements)
~elifs
~else_
}
@@ -42,21 +42,21 @@ argument(X):
Analyzer.Instruction.if_
loc
- (loc_s, Helper.v' expr, statements)
+ (loc_s, Analyzer.Expression.v expr, statements)
~elifs
~else_
}
single_instruction:
| expr = expression
{
- let expr = Helper.v' expr in
+ let expr = Analyzer.Expression.v expr in
Analyzer.Instruction.expression expr
}
| e = let_assignation { e }
| k = keyword
args = argument(expression)
{
- let args = List.map args ~f:(Helper.v') in
+ let args = List.map args ~f:(Analyzer.Expression.v) in
Analyzer.Instruction.call $loc k args
}
@@ -69,8 +69,8 @@ let_assignation:
op = assignation_operator
value = expression
{
- let variable = Helper.variable' variable
- and value = Helper.v' value in
+ let variable = Helper.variable variable
+ and value = Analyzer.Expression.v value in
Analyzer.Instruction.assign $loc variable op value
}
diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml
index b52365d..4a6b3e2 100644
--- a/lib/syntax/S.ml
+++ b/lib/syntax/S.ml
@@ -13,8 +13,6 @@
*)
-type 'a repr = Report.t list -> 'a
-
type pos = Lexing.position * Lexing.position
(** Starting and ending position for the given location *)
@@ -24,7 +22,7 @@ type ('a, 'b) variable = { pos : 'a; name : string; index : 'b option }
If missing, the index should be considered as [0].*)
-type ('a, 'b) clause = pos * 'a * 'b repr list
+type ('a, 'b) clause = pos * 'a * 'b list
(** Represent the evaluation over an expression *)
module type Expression = sig
@@ -34,7 +32,7 @@ module type Expression = sig
type t'
(** External type used outside of the module *)
- val v : t -> t' * Report.t list
+ val v : t -> t'
val ident : (pos, t) variable -> t
(*
@@ -61,54 +59,50 @@ module type Instruction = sig
type t'
(** External type used outside of the module *)
- val v : t -> t' * Report.t list
+ val v : t -> t'
type expression
- val call : pos -> T.keywords -> expression list -> t repr
+ val call : pos -> T.keywords -> expression list -> t
(** Call for an instruction like [GT] or [*CLR] *)
- val location : pos -> string -> t repr
+ val location : pos -> string -> t
(** Label for a loop *)
- val comment : pos -> t repr
+ val comment : pos -> t
(** Comment *)
- val expression : expression -> t repr
+ val expression : expression -> t
(** Raw expression *)
val if_ :
pos ->
(expression, t) clause ->
elifs:(expression, t) clause list ->
- else_:(pos * t repr list) option ->
- t repr
+ else_:(pos * t list) option ->
+ t
- val act : pos -> label:expression -> t repr list -> t repr
+ val act : pos -> label:expression -> t list -> t
val assign :
pos ->
(pos, expression) variable ->
T.assignation_operator ->
expression ->
- t repr
+ t
end
module type Location = sig
type t
type instruction
- val location : pos -> instruction list -> (t * Report.t list) repr
+ val location : pos -> instruction list -> t * Report.t list
end
module type Analyzer = sig
module Expression : Expression
-
- module Instruction :
- Instruction with type expression = Expression.t' * Report.t list
-
- module Location :
- Location with type instruction = (Instruction.t' * Report.t list) repr
+ module Instruction : Instruction with type expression = Expression.t'
+ module Location : Location with type instruction = Instruction.t'
end
(** Helper module used in order to convert elements from the differents
@@ -124,39 +118,11 @@ module Helper (E : sig
type t'
(** External type used outside of the module *)
- val v : t -> t' * Report.t list
+ val v : t -> t'
end) : sig
- val v : E.t repr -> Report.t list -> E.t' * Report.t list
- (** Convert an instruction from the internal representation *)
-
- val v' : E.t -> E.t' * Report.t list
- (** Convert an expression from the internal representation *)
-
- val variable :
- (pos, E.t) variable -> (pos, Report.t list -> E.t' * Report.t list) variable
-
- val variable' : (pos, E.t) variable -> (pos, E.t' * Report.t list) variable
+ val variable : (pos, E.t) variable -> (pos, E.t') variable
(** Convert a variable from the [Expression.t] into [Expression.t'] *)
end = struct
- let v : E.t repr -> Report.t list -> E.t' * Report.t list =
- fun v report ->
- let value = v report in
- E.v value
-
- let v' : E.t -> E.t' * Report.t list = fun v -> E.v v
-
- let variable :
- (pos, E.t) variable ->
- (pos, Report.t list -> E.t' * Report.t list) variable =
- fun variable ->
- let v' : E.t -> Report.t list -> E.t' * Report.t list =
- fun t report ->
- ignore report;
- E.v t
- in
-
- { variable with index = Option.map v' variable.index }
-
- let variable' : (pos, E.t) variable -> (pos, E.t' * Report.t list) variable =
- fun variable -> { variable with index = Option.map v' variable.index }
+ let variable : (pos, E.t) variable -> (pos, E.t') variable =
+ fun variable -> { variable with index = Option.map E.v variable.index }
end
diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml
index 10e4809..54eb295 100644
--- a/lib/syntax/check.ml
+++ b/lib/syntax/check.ml
@@ -59,9 +59,9 @@ type t =
and type Instruction.t' = 'd
and type Location.t = 'e);
expr_witness : 'a Id.typeid;
- expr' : ('b * Report.t list) Id.typeid;
+ expr' : 'b Id.typeid;
instr_witness : 'c Id.typeid;
- instr' : ('d * Report.t list) Id.typeid;
+ instr' : 'd Id.typeid;
location_witness : 'e Id.typeid;
}
-> t
@@ -90,27 +90,6 @@ module type App = sig
end
module Helper = struct
- type 'a args_list = { witness : 'a Id.typeid; values : 'a S.repr list }
- (** This types helps the compiler to know which kind of arguments are hold
- inside the list. This is just a list with the additionnal witness
- information *)
-
- (** Extract all the lines from the given module
-
- **Beware** The values are reversed. You should apply a List.rev if you
- want to keep them in the same order than the modules to apply.
- *)
- let args_i : result array list -> 'a Id.typeid -> int -> 'a args_list =
- fun args witness i ->
- let result =
- List.fold_left args ~init:{ values = []; witness }
- ~f:(fun (type a) ({ values; witness } : a args_list) t : a args_list ->
- match get witness (Array.get t i) with
- | None -> failwith "Does not match"
- | Some value_1 -> { values = (fun _ -> value_1) :: values; witness })
- in
- { result with values = result.values }
-
type 'a expr_list = { witness : 'a Id.typeid; values : 'a list }
let expr_i : result array list -> 'a Id.typeid -> int -> 'a expr_list =
@@ -123,11 +102,12 @@ module Helper = struct
| Some value_1 -> { values = value_1 :: values; witness })
in
{ result with values = result.values }
-
- let map_args report args = List.map args ~f:(fun v -> v report)
end
module Make (A : App) = struct
+ (* Global variable for the whole module *)
+ let len = Array.length A.t
+
module Expression : S.Expression with type t' = result array = struct
type t = result array
type t' = result array
@@ -172,51 +152,32 @@ module Make (A : App) = struct
results
(** Basically the same as uoperator, but operate over two operands instead
- of a single one.
-
- In order to operate over the values (application, op1, op2) I’ve
- written a function [take_arg] which works like a [Array.map3] *)
+ of a single one. *)
let boperator : S.pos -> T.boperator -> t -> t -> t =
fun pos op expr1 expr2 ->
- let take_arg : result array -> result array -> result array =
- fun expr1 expr2 ->
- let len = Array.length A.t in
- Array.init len ~f:(fun i ->
- let (E { module_ = (module S); expr_witness; _ }) =
- Array.get A.t i
- in
- match
- ( get expr_witness (Array.get expr1 i),
- get expr_witness (Array.get expr2 i) )
- with
- | Some value_1, Some value_2 ->
- let value = S.Expression.boperator pos op value_1 value_2 in
- R { witness = expr_witness; value }
- | _ -> failwith "Does not match")
- in
-
- take_arg expr1 expr2
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in
+ match
+ ( get expr_witness (Array.get expr1 i),
+ get expr_witness (Array.get expr2 i) )
+ with
+ | Some value_1, Some value_2 ->
+ let value = S.Expression.boperator pos op value_1 value_2 in
+ R { witness = expr_witness; value }
+ | _ -> failwith "Does not match")
(** Call a function. The functions list is hardcoded in lib/lexer.mll *)
let function_ : S.pos -> T.function_ -> t list -> t =
fun pos func args ->
- let len = Array.length A.t in
- let result =
- Array.init len ~f:(fun i ->
- let (E { module_ = (module S); expr_witness; _ }) =
- Array.get A.t i
- in
- (* Extract the arguments for each module *)
- let args_i = List.rev (Helper.expr_i args expr_witness i).values in
- let value = S.Expression.function_ pos func args_i in
- R { witness = expr_witness; value })
- in
- result
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in
+ (* Extract the arguments for each module *)
+ let args_i = List.rev (Helper.expr_i args expr_witness i).values in
+ let value = S.Expression.function_ pos func args_i in
+ R { witness = expr_witness; value })
let ident : (S.pos, t) S.variable -> t =
fun { pos : S.pos; name : string; index : t option } ->
- let len = Array.length A.t in
-
Array.init len ~f:(fun i ->
let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in
@@ -236,7 +197,7 @@ module Make (A : App) = struct
(** Convert each internal represention for the expression into its external
representation *)
- let v : t -> t' * Report.t list =
+ let v : t -> t' =
fun t ->
let result =
Array.map2 A.t t
@@ -247,101 +208,69 @@ module Make (A : App) = struct
let value = S.Expression.v value in
R { witness = expr'; value })
in
- (result, [])
+ result
end
module Instruction :
S.Instruction
- with type expression = Expression.t' * Report.t list
+ with type expression = Expression.t'
and type t' = result array = struct
- type expression = Expression.t' * Report.t list
+ type expression = Expression.t'
type t = result array
type t' = result array
- let location : S.pos -> string -> t S.repr =
- fun pos label report ->
- let values =
- Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) ->
- let value = S.Instruction.location pos label report in
- R { value; witness = instr_witness })
- in
- values
-
- let comment : S.pos -> t S.repr =
- fun pos report ->
- let values =
- Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) ->
- let value = S.Instruction.comment pos report in
- R { value; witness = instr_witness })
- in
- values
-
- let expression : expression -> t S.repr =
- fun expr report ->
- let expr, _report = expr in
- let results =
- Array.map2 A.t expr
- ~f:(fun
- (E { module_ = (module S); instr_witness; expr'; _ }) result ->
- match get expr' result with
- | None -> failwith "Does not match"
- | Some value ->
- (* The evaluate the instruction *)
- let value = S.Instruction.expression value report in
- R { value; witness = instr_witness })
- in
- results
+ let location : S.pos -> string -> t =
+ fun pos label ->
+ Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) ->
+ let value = S.Instruction.location pos label in
+ R { value; witness = instr_witness })
+
+ let comment : S.pos -> t =
+ fun pos ->
+ Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) ->
+ let value = S.Instruction.comment pos in
+ R { value; witness = instr_witness })
+
+ let expression : expression -> t =
+ fun expr ->
+ Array.map2 A.t expr
+ ~f:(fun (E { module_ = (module S); instr_witness; expr'; _ }) result ->
+ match get expr' result with
+ | None -> failwith "Does not match"
+ | Some value ->
+ (* The evaluate the instruction *)
+ let value = S.Instruction.expression value in
+ R { value; witness = instr_witness })
- let call : S.pos -> T.keywords -> expression list -> t S.repr =
- fun pos keyword args report ->
+ let call : S.pos -> T.keywords -> expression list -> t =
+ fun pos keyword args ->
(* The arguments are given like an array of array. Each expression is
actually the list of each expression in the differents modules. *)
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module S); expr'; instr_witness; _ }) =
+ Array.get A.t i
+ in
- (* Accumulate the results *)
- let report, args =
- List.fold_left_map args ~init:report ~f:(fun report (v, r) ->
- (r @ report, v))
- in
-
- let len = Array.length A.t in
- let result =
- Array.init len ~f:(fun i ->
- let (E { module_ = (module S); expr'; instr_witness; _ }) =
- Array.get A.t i
- in
-
- let values = List.rev (Helper.expr_i args expr' i).values in
-
- let value = S.Instruction.call pos keyword values report in
- R { witness = instr_witness; value })
- in
- result
-
- let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
- fun pos ~label instructions _report ->
- let label, report = label in
- let instructions = Helper.map_args report instructions in
- let len = Array.length A.t in
+ let values = List.rev (Helper.expr_i args expr' i).values in
- let result =
- Array.init len ~f:(fun i ->
- let (E { module_ = (module S); instr_witness; expr'; _ }) =
- Array.get A.t i
- in
- let values =
- List.rev (Helper.args_i instructions instr_witness i).values
- in
-
- match get expr' (Array.get label i) with
- | None -> failwith "Does not match"
- | Some label_i ->
- let value =
- S.Instruction.act pos ~label:label_i values report
- in
- R { witness = instr_witness; value })
- in
+ let value = S.Instruction.call pos keyword values in
+ R { witness = instr_witness; value })
- result
+ let act : S.pos -> label:expression -> t list -> t =
+ fun pos ~label instructions ->
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module S); instr_witness; expr'; _ }) =
+ Array.get A.t i
+ in
+ let values =
+ List.rev (Helper.expr_i instructions instr_witness i).values
+ in
+
+ match get expr' (Array.get label i) with
+ | None -> failwith "Does not match"
+ | Some label_i ->
+ let value = S.Instruction.act pos ~label:label_i values in
+ R { witness = instr_witness; value })
(* I think it’s one of the longest module I’ve ever written in OCaml… *)
@@ -350,131 +279,91 @@ module Make (A : App) = struct
(S.pos, expression) S.variable ->
T.assignation_operator ->
expression ->
- t S.repr =
- fun pos { pos = var_pos; name; index } op expression _report ->
- let expression, report = expression in
- let report = ref report and len = Array.length A.t in
-
- let index =
- Option.map
- (fun v ->
- let v, r = v in
- report := r;
- v)
- index
- in
-
- let result =
- Array.init len ~f:(fun i ->
- let (E { module_ = (module A); instr_witness; expr'; _ }) =
- Array.get A.t i
- in
-
- let index_i =
- Option.map
- (fun expression ->
- match get expr' (Array.get expression i) with
- | None -> failwith "Does not match"
- | Some value -> value)
- index
- in
- let variable = S.{ pos = var_pos; name; index = index_i } in
-
- match get expr' (Array.get expression i) with
- | None -> failwith "Does not match"
- | Some value ->
- let value =
- A.Instruction.assign pos variable op value !report
- in
-
- R { value; witness = instr_witness })
- in
+ t =
+ fun pos { pos = var_pos; name; index } op expression ->
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module A); instr_witness; expr'; _ }) =
+ Array.get A.t i
+ in
+
+ let index_i =
+ Option.map
+ (fun expression ->
+ match get expr' (Array.get expression i) with
+ | None -> failwith "Does not match"
+ | Some value -> value)
+ index
+ in
+ let variable = S.{ pos = var_pos; name; index = index_i } in
+
+ match get expr' (Array.get expression i) with
+ | None -> failwith "Does not match"
+ | Some value ->
+ let value = A.Instruction.assign pos variable op value in
- result
+ R { value; witness = instr_witness })
(** Helper function used to prepare the clauses *)
- let map_clause :
- Report.t list ->
- (expression, t) S.clause ->
- Report.t list * (S.pos * Expression.t' * t list) =
- fun _report clause ->
+ let map_clause : (expression, t) S.clause -> S.pos * Expression.t' * t list
+ =
+ fun clause ->
let clause_pos, expression, t = clause in
- let expression, report = expression in
- let t =
- List.map t ~f:(fun t ->
- let t = t report in
- t)
- in
+ let expression = expression in
let clause = (clause_pos, expression, t) in
- (report, clause)
+ clause
let rebuild_clause :
type a b.
int ->
a Id.typeid ->
b Id.typeid ->
- (b -> 'c) ->
S.pos * result array * result array list ->
- ('c, a) S.clause =
- fun i instr_witness expr' f clause ->
+ (b, a) S.clause =
+ fun i instr_witness expr' clause ->
let pos_clause, expr_clause, ts = clause in
match get expr' (Array.get expr_clause i) with
| None -> failwith "Does not match"
| Some value ->
- let ts = Helper.args_i ts instr_witness i in
+ let ts = Helper.expr_i ts instr_witness i in
let ts = List.rev ts.values in
- let clause = (pos_clause, f value, ts) in
+ let clause = (pos_clause, value, ts) in
clause
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 clause ~elifs ~else_ report ->
+ else_:(S.pos * t list) option ->
+ t =
+ fun pos clause ~elifs ~else_ ->
(* First, apply the report for all the instructions *)
- let report, clause = map_clause report clause in
-
- let report, elifs = List.fold_left_map elifs ~init:report ~f:map_clause in
- let report, else_ =
+ let clause = map_clause clause and elifs = List.map elifs ~f:map_clause in
+ let else_ =
match else_ with
- | None -> (report, None)
- | Some (pos, instructions) ->
- let instructions = Helper.map_args report instructions in
- (report, Some (pos, instructions))
- in
- let len = Array.length A.t in
-
- let result =
- Array.init len ~f:(fun i ->
- let (E { module_ = (module A); instr_witness; expr'; _ }) =
- Array.get A.t i
- in
-
- (* This function helps to build the expression in the clauses *)
- let f = Fun.id in
-
- let clause = rebuild_clause i instr_witness expr' f clause
- and elifs =
- List.map elifs ~f:(rebuild_clause i instr_witness expr' f)
- and else_ =
- match else_ with
- | None -> None
- | Some (pos, instructions) ->
- let elses = Helper.args_i instructions instr_witness i in
- Some (pos, List.rev elses.values)
- in
-
- let value = A.Instruction.if_ pos clause ~elifs ~else_ report in
- R { value; witness = instr_witness })
+ | None -> None
+ | Some (pos, instructions) -> Some (pos, instructions)
in
-
- result
+ Array.init len ~f:(fun i ->
+ let (E { module_ = (module A); instr_witness; expr'; _ }) =
+ Array.get A.t i
+ in
+
+ let clause = rebuild_clause i instr_witness expr' clause
+ and elifs = List.map elifs ~f:(rebuild_clause i instr_witness expr')
+ and else_ =
+ match else_ with
+ | None -> None
+ | Some (pos, instructions) ->
+ let elses = Helper.expr_i instructions instr_witness i in
+ Some (pos, List.rev elses.values)
+ in
+
+ let value = A.Instruction.if_ pos clause ~elifs ~else_ in
+ R { value; witness = instr_witness })
(** This code is almost a copy/paste from Expression.v but I did not found
a way to factorize it. *)
- let v : t -> t' * Report.t list =
+ let v : t -> t' =
fun t ->
let result =
Array.map2 A.t t
@@ -486,38 +375,29 @@ module Make (A : App) = struct
let value = S.Instruction.v value in
R { witness = instr'; value })
in
- (result, [])
+ result
end
module Location :
- S.Location
- with type t = result array
- and type instruction = (Instruction.t' * Report.t list) S.repr = struct
- type instruction = (Instruction.t' * Report.t list) S.repr
+ S.Location with type t = result array and type instruction = Instruction.t' =
+ struct
+ type instruction = Instruction.t'
type t = result array
- let location : S.pos -> instruction list -> (t * Report.t list) S.repr =
- fun pos instructions report ->
+ let location : S.pos -> instruction list -> t * Report.t list =
+ fun pos args ->
ignore pos;
- (* Extract the instructions and accumulate the result *)
- let instructions = Helper.map_args report instructions in
-
- let report, args =
- List.fold_left_map instructions ~init:report ~f:(fun report (v, r) ->
- (r @ report, v))
- in
-
- let report = ref report and len = Array.length A.t in
+ let report = ref [] in
let result =
Array.init len ~f:(fun i ->
let (E { module_ = (module A); instr'; location_witness; _ }) =
Array.get A.t i
in
- let instructions = List.rev (Helper.args_i args instr' i).values in
- let value, re = A.Location.location pos instructions !report in
- report := re;
+ let instructions = List.rev (Helper.expr_i args instr' i).values in
+ let value, re = A.Location.location pos instructions in
+ report := List.rev_append re !report;
R { value; witness = location_witness })
in
(result, !report)
diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml
index d1683cd..1240e72 100644
--- a/lib/syntax/dead_end.ml
+++ b/lib/syntax/dead_end.ml
@@ -10,11 +10,11 @@ module Expression = struct
let default = ()
end)
- let v : t -> t' * Report.t list = fun () -> ((), [])
+ let v : t -> t' = fun () -> ()
end
module Instruction = struct
- type expression = Expression.t' * Report.t list
+ type expression = Expression.t'
type cause = Missing_else | Unchecked_path
type state = {
@@ -24,7 +24,7 @@ module Instruction = struct
pos : (cause * S.pos) option;
}
- type t = state * Report.t list
+ type t = state
type t' = state
(** For each instruction, return thoses two informations :
@@ -33,7 +33,7 @@ module Instruction = struct
- the last instruction is a [gt]
*)
- let v : t -> t' * Report.t list = fun t -> t
+ let v : t -> t' = fun t -> t
let default =
{
@@ -44,36 +44,33 @@ module Instruction = struct
}
(** Call for an instruction like [GT] or [*CLR] *)
- let call : S.pos -> T.keywords -> expression list -> t S.repr =
- fun pos f _ report ->
+ let call : S.pos -> T.keywords -> expression list -> t =
+ fun pos f _ ->
ignore pos;
match f with
| T.Goto | T.XGoto ->
- ({ block_pos = pos; has_gt = true; is_gt = true; pos = None }, report)
- | T.Gosub ->
- ({ block_pos = pos; has_gt = false; is_gt = true; pos = None }, report)
- | _ -> (default, report)
+ { block_pos = pos; has_gt = true; is_gt = true; pos = None }
+ | T.Gosub -> { block_pos = pos; has_gt = false; is_gt = true; pos = None }
+ | _ -> default
(** Label for a loop *)
- let location : S.pos -> string -> t S.repr =
- fun _ _ report -> (default, report)
+ let location : S.pos -> string -> t = fun _ _ -> default
(** Comment *)
- let comment : S.pos -> t S.repr = fun _ report -> (default, report)
+ let comment : S.pos -> t = fun _ -> default
(** Raw expression *)
- let expression : expression -> t S.repr = fun _ report -> (default, report)
+ let expression : expression -> t = fun _ -> default
(** The content of a block is very linear, I only need to check the last element *)
- let check_block : S.pos -> t S.repr list -> t S.repr =
- fun pos instructions report ->
+ let check_block : S.pos -> t list -> t =
+ fun pos instructions ->
let last_element =
- List.fold_left instructions ~init:(default, report)
- ~f:(fun (t, report) instruction ->
- let result, report = instruction report in
+ List.fold_left instructions ~init:default ~f:(fun t instruction ->
+ let result = instruction in
let has_gt = result.has_gt || t.has_gt in
let is_gt = result.is_gt || t.is_gt in
- ({ result with block_pos = pos; is_gt; has_gt }, report))
+ { result with block_pos = pos; is_gt; has_gt })
in
last_element
@@ -81,27 +78,27 @@ module Instruction = struct
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 clause ~elifs ~else_ report ->
+ else_:(S.pos * t list) option ->
+ t =
+ fun pos clause ~elifs ~else_ ->
(* For each block, evaluate the instructions *)
- let report, res, has_gt, is_gt =
- List.fold_left ~init:(report, [], false, false) (clause :: elifs)
- ~f:(fun (report, acc, has_gt, is_gt) clause ->
+ let res, has_gt, is_gt =
+ List.fold_left ~init:([], false, false) (clause :: elifs)
+ ~f:(fun (acc, has_gt, is_gt) clause ->
let pos, _, instructions = clause in
- let clause_t, report = check_block pos instructions report in
+ let clause_t = check_block pos instructions in
let has_gt = has_gt || clause_t.has_gt
and is_gt = is_gt || clause_t.is_gt in
- (report, (clause_t, pos) :: acc, has_gt, is_gt))
+ ((clause_t, pos) :: acc, has_gt, is_gt))
in
- let else_pos, else_block, report =
+ let else_pos, else_block =
match else_ with
| Some (pos, instructions) ->
- let block, report = check_block pos instructions report in
- (pos, block, report)
- | None -> (pos, default, report)
+ let block = check_block pos instructions in
+ (pos, block)
+ | None -> (pos, default)
in
let has_gt = has_gt || else_block.has_gt
and is_gt = is_gt || else_block.is_gt in
@@ -110,7 +107,7 @@ module Instruction = struct
(* Check if one of the clauses already holds a dead end*)
match List.find_opt res ~f:(fun (res, _) -> res.pos != None) with
- | Some (v, _) -> (v, report)
+ | Some (v, _) -> v
| None -> (
match (is_gt, has_gt) with
| _, true -> (
@@ -119,41 +116,37 @@ module Instruction = struct
match List.find_opt blocks ~f:(fun (f, _) -> not f.is_gt) with
| None ->
(* Every branch in the if is covered. It’s ok. *)
- ({ default with block_pos = pos; is_gt; has_gt }, report)
+ { default with block_pos = pos; is_gt; has_gt }
| Some (_, pos) ->
(* TODO check if [pos] is the whole block *)
let cause =
match else_ with None -> Missing_else | _ -> Unchecked_path
in
- ( { default with block_pos = pos; pos = Some (cause, pos) },
- report ))
- | _, _ -> ({ default with block_pos = pos; has_gt; is_gt }, report))
+ { default with block_pos = pos; pos = Some (cause, pos) })
+ | _, _ -> { default with block_pos = pos; has_gt; is_gt })
- let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
- fun pos ~label expressions report ->
+ let act : S.pos -> label:expression -> t list -> t =
+ fun pos ~label expressions ->
ignore label;
- check_block pos expressions report
+ check_block pos expressions
let assign :
S.pos ->
(S.pos, expression) S.variable ->
T.assignation_operator ->
expression ->
- t S.repr =
- fun _ _ _ _ report -> (default, report)
+ t =
+ fun _ _ _ _ -> default
end
module Location = struct
type t = unit
- type instruction = (Instruction.t' * Report.t list) S.repr
+ type instruction = Instruction.t'
- let location : S.pos -> instruction list -> (t * Report.t list) S.repr =
- fun _pos instructions report ->
+ let location : S.pos -> instruction list -> t * Report.t list =
+ fun _pos instructions ->
( (),
- List.fold_left instructions ~init:report ~f:(fun report instruction ->
- let t, r = instruction [] in
-
- let report = List.rev_append r report in
+ List.fold_left instructions ~init:[] ~f:(fun report t ->
match (t.Instruction.is_gt, t.Instruction.pos) with
| false, Some (cause, value) ->
ignore cause;
diff --git a/lib/syntax/tree.ml b/lib/syntax/tree.ml
index cf02bf6..d4af905 100644
--- a/lib/syntax/tree.ml
+++ b/lib/syntax/tree.ml
@@ -36,7 +36,7 @@ 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' * Report.t list = fun 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 -> string -> t = fun pos l -> Ast.Literal (pos, l)
@@ -59,78 +59,57 @@ end
module Instruction :
S.Instruction
- with type expression = Expression.t' * Report.t list
+ 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' * Report.t list = fun t -> (t, [])
+ let v : t -> t' = fun t -> t
- type expression = Expression.t' * Report.t list
+ type expression = Expression.t'
- let call : S.pos -> T.keywords -> expression list -> t S.repr =
- fun pos name args _ ->
- let args = List.map ~f:fst args in
- Ast.Call (pos, name, args)
+ let call : S.pos -> T.keywords -> expression list -> t =
+ fun pos name args -> Ast.Call (pos, name, args)
- let location : S.pos -> string -> t S.repr =
- fun loc label _ -> Ast.Location (loc, label)
+ let location : S.pos -> string -> t =
+ fun loc label -> Ast.Location (loc, label)
- let comment : S.pos -> t S.repr = fun pos _ -> Ast.Comment pos
-
- let expression : expression -> t S.repr =
- fun expr _ -> Ast.Expression (fst expr)
+ 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 S.repr list) option ->
- t S.repr =
- fun pos predicate ~elifs ~else_ _ ->
- let clause (pos, expr, repr) =
- let repr = List.map ~f:(fun instr -> instr []) repr in
- (pos, fst @@ expr, repr)
- in
+ 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) ->
- List.map ~f:(fun instr -> instr []) instructions
+ match else_ with None -> [] | Some (_, instructions) -> instructions
in
Ast.If { loc = pos; then_ = clause predicate; elifs; else_ }
- let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
- fun pos ~label statements _ ->
- let label = fst label
- and statements = List.map ~f:(fun instr -> instr []) statements in
- Ast.Act { loc = pos; label; statements }
+ 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 S.repr =
- fun pos_loc { pos; name; index } op expr _ ->
+ t =
+ fun pos_loc { pos; name; index } op expr ->
(*let index = Option.map (fun i -> fst @@ Expression.observe (i [])) index*)
- let index = Option.map fst index in
- let expr = fst expr in
Ast.Declaration (pos_loc, { pos; name; index }, op, expr)
end
module Location = struct
- type instruction = (Instruction.t' * Report.t list) S.repr
+ type instruction = Instruction.t'
type t = S.pos * S.pos Ast.statement list
- let location : S.pos -> instruction list -> (t * Report.t list) S.repr =
- fun pos block report ->
- let report, block =
- List.fold_left_map ~init:report block ~f:(fun report b ->
- let v, report = b report in
- (report, v))
- in
- ((pos, block), report)
+ let location : S.pos -> instruction list -> t * Report.t list =
+ fun pos block -> ((pos, block), [])
end
diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml
index 683a27a..485fbe2 100644
--- a/lib/syntax/type_of.ml
+++ b/lib/syntax/type_of.ml
@@ -144,9 +144,9 @@ end
module Expression = struct
type state = { result : Helper.t; pos : S.pos; empty : bool }
type t = state * Report.t list
- type t' = state
+ type t' = state * Report.t list
- let v : t -> t' * Report.t list = fun t -> t
+ let v : t -> t' = fun t -> t
let arg_of_repr : state -> Helper.argument_repr =
fun { result; pos; empty } ->
@@ -352,29 +352,26 @@ end
module Instruction = struct
type t = Report.t list
- type t' = unit
+ type t' = Report.t list
- let v : t -> t' * Report.t list = fun local_report -> ((), local_report)
+ let v : t -> t' = fun local_report -> local_report
- type expression = Expression.t' * Report.t list
+ type expression = Expression.t'
(** Call for an instruction like [GT] or [*CLR] *)
- let call : S.pos -> T.keywords -> expression list -> t S.repr =
- fun _pos _ expressions report ->
- List.fold_left expressions ~init:report ~f:(fun acc a ->
+ let call : S.pos -> T.keywords -> expression list -> t =
+ fun _pos _ expressions ->
+ List.fold_left expressions ~init:[] ~f:(fun acc a ->
let _, report = a in
(List.rev_append report) acc)
- let location : S.pos -> string -> t S.repr = fun _pos _ report -> report
+ let location : S.pos -> string -> t = fun _pos _ -> []
(** Comment *)
- let comment : S.pos -> t S.repr = fun _pos report -> report
+ let comment : S.pos -> t = fun _pos -> []
(** Raw expression *)
- let expression : expression -> t S.repr =
- fun expression report ->
- ignore report;
- snd expression
+ let expression : expression -> t = fun expression -> snd expression
(** Helper function used in the [if_] function. *)
let fold_clause : t -> (expression, t) S.clause -> t =
@@ -386,37 +383,36 @@ module Instruction = struct
List.fold_left instructions
~init:(r @ r2 @ report)
~f:(fun acc a ->
- let report = a [] in
+ let report = a in
(List.rev_append report) acc)
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 clause ~elifs ~else_ report ->
+ else_:(S.pos * t list) option ->
+ t =
+ fun _pos clause ~elifs ~else_ ->
(* Traverse the whole block recursively *)
- let report = fold_clause report clause in
+ let report = fold_clause [] clause in
let report = List.fold_left elifs ~f:fold_clause ~init:report in
match else_ with
| None -> report
| Some (_, instructions) ->
List.fold_left instructions ~init:report ~f:(fun acc a ->
- let report = a [] in
+ let report = a in
(List.rev_append report) acc)
- let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
- fun _pos ~label instructions report ->
- let result, r = label in
- let report = r @ report in
+ let act : S.pos -> label:expression -> t list -> t =
+ fun _pos ~label instructions ->
+ let result, report = label in
let report =
Helper.compare Helper.String (Expression.arg_of_repr result) report
in
List.fold_left instructions ~init:report ~f:(fun acc a ->
- let report = a [] in
+ let report = a in
(List.rev_append report) acc)
let assign :
@@ -424,11 +420,11 @@ module Instruction = struct
(S.pos, expression) S.variable ->
T.assignation_operator ->
expression ->
- t S.repr =
- fun pos variable _ expression report ->
- let right_expression, r = expression in
+ t =
+ fun pos variable _ expression ->
+ let right_expression, report = expression in
let expr1, report' = Expression.ident variable in
- let report = report' @ r @ report in
+ let report = report' @ report in
match right_expression.empty with
| true -> report
| false -> (
@@ -451,15 +447,14 @@ end
module Location = struct
type t = unit
- type instruction = (Instruction.t' * Report.t list) S.repr
-
- let location : S.pos -> instruction list -> (t * Report.t list) S.repr =
- fun _pos instructions report ->
- let (), report =
- List.fold_left instructions ~init:((), report)
- ~f:(fun ((), report) instruction ->
- let _, report' = instruction [] in
- ((), report' @ report))
+ type instruction = Instruction.t'
+
+ let location : S.pos -> instruction list -> t * Report.t list =
+ fun _pos instructions ->
+ let report =
+ List.fold_left instructions ~init:[] ~f:(fun report instruction ->
+ let report' = instruction in
+ report' @ report)
in
((), report)
end