From 0d5bcaea3370697822675d9f8d25bca34c02505e Mon Sep 17 00:00:00 2001 From: Chimrod <> Date: Thu, 9 Nov 2023 16:04:09 +0100 Subject: Made the compose evaluation lazy --- lib/syntax/compose.ml | 71 ++++++++++++++++++++++++++++---------------- lib/syntax/nested_strings.ml | 28 ++++++++++------- lib/syntax/type_of.ml | 36 +++++++++++++--------- 3 files changed, 85 insertions(+), 50 deletions(-) (limited to 'lib/syntax') diff --git a/lib/syntax/compose.ml b/lib/syntax/compose.ml index dcc1a86..670249a 100644 --- a/lib/syntax/compose.ml +++ b/lib/syntax/compose.ml @@ -14,60 +14,79 @@ module Expression (E : S.Expression) = struct signatures differs a bit from the standard signature as they get the result from E.t in last argument *) - val ident : (S.pos, E.t' * t) S.variable -> E.t' -> t - val integer : S.pos -> string -> E.t' -> t - val literal : S.pos -> (E.t' * t) T.literal list -> E.t' -> t - val function_ : S.pos -> T.function_ -> (E.t' * t) list -> E.t' -> t - val uoperator : S.pos -> T.uoperator -> E.t' * t -> E.t' -> t - val boperator : S.pos -> T.boperator -> E.t' * t -> E.t' * t -> E.t' -> t - - val v : E.t' * t -> t' + val ident : (S.pos, E.t' Lazy.t * t) S.variable -> E.t' Lazy.t -> t + val integer : S.pos -> string -> E.t' Lazy.t -> t + val literal : S.pos -> (E.t' Lazy.t * t) T.literal list -> E.t' Lazy.t -> t + + val function_ : + S.pos -> T.function_ -> (E.t' Lazy.t * t) list -> E.t' Lazy.t -> t + + val uoperator : S.pos -> T.uoperator -> E.t' Lazy.t * t -> E.t' Lazy.t -> t + + val boperator : + S.pos -> + T.boperator -> + E.t' Lazy.t * t -> + E.t' Lazy.t * t -> + E.t' Lazy.t -> + t + + val v : E.t' Lazy.t * t -> t' (** Convert from the internal representation to the external one. *) end module Make (M : SIG) : S.Expression with type t' = M.t' = struct - type t = E.t * M.t + type t = E.t Lazy.t * M.t type t' = M.t' - let v : t -> t' = fun (type_of, v) -> M.v (E.v type_of, v) + let v' : E.t Lazy.t -> E.t' Lazy.t = Lazy.map E.v + let fst' : 'a Lazy.t * _ -> 'a = fun v -> Lazy.force (fst v) + let v : t -> t' = fun (type_of, v) -> M.v (v' type_of, v) let ident : (S.pos, t) S.variable -> t = fun { pos; name : string; index : t option } -> - let t' = E.ident { pos; name; index = Option.map fst index } in - let index' = Option.map (fun (e, m) -> (E.v e, m)) index in - (t', M.ident { pos; name; index = index' } (E.v @@ t')) + let t' = lazy (E.ident { pos; name; index = Option.map fst' index }) in + let index' = Option.map (fun (e, m) -> (v' e, m)) index in + (t', M.ident { pos; name; index = index' } (v' t')) let integer : S.pos -> string -> t = fun pos i -> - let t' = E.integer pos i in - (t', M.integer pos i (E.v t')) + let t' = lazy (E.integer pos i) in + (t', M.integer pos i (v' t')) let literal : S.pos -> t T.literal list -> t = fun pos litts -> - let e_litts = List.map litts ~f:(T.map_litteral ~f:fst) in let litts' = - List.map litts ~f:(T.map_litteral ~f:(fun (e, m) -> (E.v e, m))) + List.map litts ~f:(T.map_litteral ~f:(fun (e, m) -> (v' e, m))) in - let t' = E.literal pos e_litts in - (t', M.literal pos litts' (E.v t')) + let t' = + lazy + (let e_litts = List.map litts ~f:(T.map_litteral ~f:fst') in + E.literal pos e_litts) + in + (t', M.literal pos litts' (v' t')) let function_ : S.pos -> T.function_ -> t list -> t = fun pos f expressions -> let e = List.map ~f:fst expressions - and expressions' = List.map ~f:(fun (e, m) -> (E.v e, m)) expressions in + and expressions' = List.map ~f:(fun (e, m) -> (v' e, m)) expressions in - let t' = E.function_ pos f e in - (t', M.function_ pos f expressions' (E.v t')) + let t' = + lazy + (let e' = List.map ~f:Lazy.force e in + E.function_ pos f e') + in + (t', M.function_ pos f expressions' (v' t')) let uoperator : S.pos -> T.uoperator -> t -> t = fun pos op (t, expr) -> - let t' = E.uoperator pos op t in - (t', M.uoperator pos op (E.v t, expr) (E.v t')) + let t' = lazy (E.uoperator pos op (Lazy.force t)) in + (t', M.uoperator pos op (v' t, expr) (v' t')) let boperator : S.pos -> T.boperator -> t -> t -> t = fun pos op (t1, expr1) (t2, expr2) -> - let t' = E.boperator pos op t1 t2 in - (t', M.boperator pos op (E.v t1, expr1) (E.v t2, expr2) (E.v t')) + let t' = lazy (E.boperator pos op (Lazy.force t1) (Lazy.force t2)) in + (t', M.boperator pos op (v' t1, expr1) (v' t2, expr2) (v' t')) end end diff --git a/lib/syntax/nested_strings.ml b/lib/syntax/nested_strings.ml index fcd0b91..7e49ace 100644 --- a/lib/syntax/nested_strings.ml +++ b/lib/syntax/nested_strings.ml @@ -10,35 +10,42 @@ module Expression = TypeBuilder.Make (struct type t = Report.t list type t' = Report.t list - let v : Get_type.t * t -> t' = snd + let v : Get_type.t Lazy.t * t -> t' = snd (** Identify the expressions reprented as string. That’s here that the report are added. All the rest of the module only push thoses warning to the top level. *) - let literal : S.pos -> (Get_type.t * t) T.literal list -> Get_type.t -> t = + let literal : + S.pos -> (Get_type.t Lazy.t * t) T.literal list -> Get_type.t Lazy.t -> t + = fun pos content _type_of -> match content with | [ T.Expression [ (t', _) ]; T.Text "" ] -> ( - match Get_type.get_type t' with + match Get_type.get_type (Lazy.force t') with | Get_type.Integer -> [] | _ -> let msg = Report.debug pos "This expression can be simplified" in [ msg ]) | _ -> [] - let ident : (S.pos, Get_type.t * t) S.variable -> Get_type.t -> t = + let ident : + (S.pos, Get_type.t Lazy.t * t) S.variable -> Get_type.t Lazy.t -> t = fun variable _type_of -> match variable.index with None -> [] | Some (_, t) -> t - let integer : S.pos -> string -> Get_type.t -> t = + let integer : S.pos -> string -> Get_type.t Lazy.t -> t = fun pos t _type_of -> ignore pos; ignore t; [] let function_ : - S.pos -> T.function_ -> (Get_type.t * t) list -> Get_type.t -> t = + S.pos -> + T.function_ -> + (Get_type.t Lazy.t * t) list -> + Get_type.t Lazy.t -> + t = fun pos f expressions _type_of -> ignore pos; ignore f; @@ -48,7 +55,8 @@ module Expression = TypeBuilder.Make (struct in exprs - let uoperator : S.pos -> T.uoperator -> Get_type.t * t -> Get_type.t -> t = + let uoperator : + S.pos -> T.uoperator -> Get_type.t Lazy.t * t -> Get_type.t Lazy.t -> t = fun pos op r _type_of -> ignore op; ignore pos; @@ -57,9 +65,9 @@ module Expression = TypeBuilder.Make (struct let boperator : S.pos -> T.boperator -> - Get_type.t * t -> - Get_type.t * t -> - Get_type.t -> + Get_type.t Lazy.t * t -> + Get_type.t Lazy.t * t -> + Get_type.t Lazy.t -> t = fun pos op (_, r1) (_, r2) _type_of -> ignore pos; diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml index 7b9a67e..c532a96 100644 --- a/lib/syntax/type_of.ml +++ b/lib/syntax/type_of.ml @@ -137,22 +137,23 @@ end module TypeBuilder = Compose.Expression (Get_type) -type t' = { result : Get_type.t; pos : S.pos; empty : bool } +type t' = { result : Get_type.t Lazy.t; pos : S.pos; empty : bool } -let arg_of_repr : Get_type.t -> S.pos -> Helper.argument_repr = - fun type_of pos -> { pos; t = type_of } +let arg_of_repr : Get_type.t Lazy.t -> S.pos -> Helper.argument_repr = + fun type_of pos -> { pos; t = Lazy.force type_of } module TypedExpression = struct type nonrec t' = t' * Report.t list type state = { pos : S.pos; empty : bool } type t = state * Report.t list - let v : Get_type.t * t -> t' = + let v : Get_type.t Lazy.t * t -> t' = fun (type_of, (t, r)) -> ({ result = type_of; pos = t.pos; empty = t.empty }, r) (** The variable has type string when starting with a '$' *) - let ident : (S.pos, Get_type.t * t) S.variable -> Get_type.t -> t = + let ident : + (S.pos, Get_type.t Lazy.t * t) S.variable -> Get_type.t Lazy.t -> t = fun var _type_of -> let empty = false in @@ -166,7 +167,7 @@ module TypedExpression = struct in ({ pos = var.pos; empty }, report) - let integer : S.pos -> string -> Get_type.t -> t = + let integer : S.pos -> string -> Get_type.t Lazy.t -> t = fun pos value _type_of -> let int_value = int_of_string_opt value in @@ -179,7 +180,9 @@ module TypedExpression = struct ({ pos; empty }, report) - let literal : S.pos -> (Get_type.t * t) T.literal list -> Get_type.t -> t = + let literal : + S.pos -> (Get_type.t Lazy.t * t) T.literal list -> Get_type.t Lazy.t -> t + = fun pos values type_of -> ignore type_of; let init = ({ pos; empty = true }, []) in @@ -188,7 +191,7 @@ module TypedExpression = struct | T.Text t -> let empty = String.equal t String.empty in ({ pos; empty }, report) - | T.Expression (t : (Get_type.t * t) list) -> + | T.Expression (t : (Get_type.t Lazy.t * t) list) -> (* Report the warning bottom top *) let result, r = List.fold_left t ~init:(None, []) @@ -207,7 +210,11 @@ module TypedExpression = struct result let function_ : - S.pos -> T.function_ -> (Get_type.t * t) list -> Get_type.t -> t = + S.pos -> + T.function_ -> + (Get_type.t Lazy.t * t) list -> + Get_type.t Lazy.t -> + t = fun pos function_ params _type_of -> (* 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 @@ -297,7 +304,8 @@ module TypedExpression = struct (default, report) (** Unary operator like [-123] or [+'Text']*) - let uoperator : S.pos -> T.uoperator -> Get_type.t * t -> Get_type.t -> t = + let uoperator : + S.pos -> T.uoperator -> Get_type.t Lazy.t * t -> Get_type.t Lazy.t -> t = fun pos operator t1 type_of -> ignore type_of; let type_of, (t, report) = t1 in @@ -312,9 +320,9 @@ module TypedExpression = struct let boperator : S.pos -> T.boperator -> - Get_type.t * t -> - Get_type.t * t -> - Get_type.t -> + Get_type.t Lazy.t * t -> + Get_type.t Lazy.t * t -> + Get_type.t Lazy.t -> t = fun pos operator (type_1, t1) (type_2, t2) type_of -> ignore type_of; @@ -457,7 +465,7 @@ module Instruction = struct match right_expression.empty with | true -> report | false -> ( - let var_type = Get_type.ident variable in + let var_type = Lazy.from_val (Get_type.ident variable) in let op1 = arg_of_repr var_type variable.pos in let op2 = arg_of_repr right_expression.result right_expression.pos in -- cgit v1.2.3