From c20b6dd7533775eaed045950e04175b020ac52c4 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Thu, 2 Aug 2018 19:44:49 +0200 Subject: Update expression evaluation --- src/expressions/collect_sources.ml | 29 +++++++------- src/expressions/evaluate.ml | 80 ++++++++++++++++++++------------------ src/expressions/id_type.ml | 15 +++++++ src/expressions/shift_expr.ml | 67 +++++++++++++++++++++++++++++++ src/expressions/show_expr.ml | 19 +++++---- src/expressions/sym_expr.ml | 20 +++++----- 6 files changed, 156 insertions(+), 74 deletions(-) mode change 100755 => 100644 src/expressions/collect_sources.ml mode change 100755 => 100644 src/expressions/evaluate.ml create mode 100644 src/expressions/id_type.ml create mode 100644 src/expressions/shift_expr.ml mode change 100755 => 100644 src/expressions/show_expr.ml mode change 100755 => 100644 src/expressions/sym_expr.ml (limited to 'src/expressions') diff --git a/src/expressions/collect_sources.ml b/src/expressions/collect_sources.ml old mode 100755 new mode 100644 index 32b40be..9698057 --- a/src/expressions/collect_sources.ml +++ b/src/expressions/collect_sources.ml @@ -29,7 +29,7 @@ module T = struct let bool b = () - let observe () x = x + let observe : unit -> 'a -> 'a = fun () x -> x end @@ -39,7 +39,8 @@ module R = struct type 'a t = 'a obs - let cell (c:Cell.t) set = Cell.Set.add (Cell.to_pair c) set + let cell : Cell.t -> Cell.Set.t -> Cell.Set.t = + fun c set -> Cell.Set.add (Cell.to_pair c) set let range c1 c2 set = begin @@ -60,27 +61,25 @@ module R = struct end -let observe f value = f value - -let value v () = T.observe v +type obs = Cell.Set.t -> Cell.Set.t -let ref r () = R.observe r +type t = obs -let call0 ident () acc = acc +let observe (f:obs) (value :Cell.Set.t) = f value -let call1 ident p1 () acc = observe p1 acc +let value v acc = T.observe v acc -let call2 ident p1 p2 () acc = observe p2 (observe p1 acc) +let ref r acc = R.observe r acc -let call3 ident p1 p2 p3 () acc = observe p3 (observe p2 (observe p1 acc)) +let call0 ident acc = acc -let callN ident params () acc = List.fold_left (fun acc p -> observe p acc) acc params +let call1 ident p1 acc = observe p1 acc -let expression e () = e +let call2 ident p1 p2 acc = observe p2 (observe p1 acc) -type obs = Cell.Set.t -> Cell.Set.t +let call3 ident p1 p2 p3 acc = observe p3 (observe p2 (observe p1 acc)) -type t = unit +let callN ident params acc = List.fold_left (fun acc p -> observe p acc) acc params -type repr = obs +let expression e acc = e acc diff --git a/src/expressions/evaluate.ml b/src/expressions/evaluate.ml old mode 100755 new mode 100644 index ff44097..fbf2a18 --- a/src/expressions/evaluate.ml +++ b/src/expressions/evaluate.ml @@ -26,12 +26,6 @@ type 'a value = type existencialResult = | Result : 'a value -> existencialResult [@@unboxed] -type t = (Functions.C.t * (int * int -> ScTypes.Result.t option)) - -type repr = existencialResult - -type obs = ScTypes.Result.t - module T:Sym_type.SYM_TYPE with type 'a obs = existencialResult = struct type 'a t = 'a value @@ -50,6 +44,12 @@ module T:Sym_type.SYM_TYPE with type 'a obs = existencialResult = struct end +type dic = (Functions.C.t * (int * int -> ScTypes.Result.t option)) + +type t = dic -> existencialResult + +type obs = dic -> ScTypes.Result.t + module R = Eval_ref (** Extract the type and the content from a value *) @@ -97,63 +97,67 @@ let ref r (_, mapper) = begin | R.Matrix (t, l) -> Result (Matrix(t, l)) end +let observe repr catalog = begin + let Result r = repr catalog in match r with + | Bool b -> ScTypes.Result.Ok (ScTypes.Type.boolean b) + | String s -> ScTypes.Result.Ok (ScTypes.Type.string s) + | Num (format, n) -> + begin match format with + (* We can only match numeric formats here *) + | ScTypes.DataFormat.Date -> ScTypes.Result.Ok (ScTypes.Type.date n) + | ScTypes.DataFormat.Number -> ScTypes.Result.Ok (ScTypes.Type.number n) + end + | _ -> raise Errors.TypeError +end + +let expression e = e + let call0 ident (catalog, _) = let name' = UTF8.to_utf8string ident in - let arg1 = (Functions.t_unit, ()) in + let (arg1:(unit Functions.C.argument * unit)) = (Functions.t_unit, ()) in wrap_call (Functions.C.eval1 catalog name' arg1) (fun () -> raise Errors.TypeError) -let call1 ident p1 (catalog, _) = +let call1 ident p1 ((catalog, _) as c) = let name' = UTF8.to_utf8string ident in - let (Result r1) = p1 in + (* Evaluate here p1 expression *) + let (Result r1) = p1 c in let arg1 = get_argument r1 in wrap_call (Functions.C.eval1 catalog name' arg1) - (fun () -> build_format_list [p1]) + (fun () -> build_format_list [Result r1]) -let call2 ident p1 p2 (catalog, _) = +let call2 ident p1 p2 ((catalog, _) as c) = let name' = UTF8.to_utf8string ident in - let (Result r1) = p1 in - let (Result r2) = p2 in + let (Result r1) = p1 c in + let (Result r2) = p2 c in let arg1 = get_argument r1 and arg2 = get_argument r2 in wrap_call (Functions.C.eval2 catalog name' arg1 arg2) - (fun () -> build_format_list [p1; p2]) + (fun () -> build_format_list [Result r1; Result r2]) -let call3 ident p1 p2 p3 (catalog, _) = +let call3 ident p1 p2 p3 ((catalog, _) as c) = let name' = UTF8.to_utf8string ident in - let (Result r1) = p1 in - let (Result r2) = p2 in - let (Result r3) = p3 in + let (Result r1) = p1 c in + let (Result r2) = p2 c in + let (Result r3) = p3 c in let arg1 = get_argument r1 and arg2 = get_argument r2 and arg3 = get_argument r3 in wrap_call (Functions.C.eval3 catalog name' arg1 arg2 arg3) - (fun () -> build_format_list [p1; p2 ; p3]) + (fun () -> build_format_list [Result r1; Result r2; Result r3]) -let callN ident params (catalog, _) = - let signature = List.map (fun (Result r) -> +let callN ident params ((catalog, _) as c) = + + let map_params expression = begin + let (Result r) = expression c in let formatter = Format.str_formatter in Functions.repr formatter (fst @@ get_argument r); - Format.flush_str_formatter ()) params in + Format.flush_str_formatter () + end in + let signature = List.map map_params params in raise (Errors.Undefined (ident, signature)) -let expression e _ = e - -let observe repr = begin - let Result r = repr in match r with - | Bool b -> ScTypes.Result.Ok (ScTypes.Type.boolean b) - | String s -> ScTypes.Result.Ok (ScTypes.Type.string s) - | Num (format, n) -> - begin match format with - (* We can only match numeric formats here *) - | ScTypes.DataFormat.Date -> ScTypes.Result.Ok (ScTypes.Type.date n) - | ScTypes.DataFormat.Number -> ScTypes.Result.Ok (ScTypes.Type.number n) - end - | _ -> raise Errors.TypeError - -end - diff --git a/src/expressions/id_type.ml b/src/expressions/id_type.ml new file mode 100644 index 0000000..d84ddfa --- /dev/null +++ b/src/expressions/id_type.ml @@ -0,0 +1,15 @@ +type 'a t = 'a ScTypes.Type.t + +type 'a obs = 'a ScTypes.Type.t + +let str s = ScTypes.Type.string s + +let num n = ScTypes.Type.number n + +let date d = ScTypes.Type.date d + +let bool b = ScTypes.Type.boolean b + +let observe x = x + + diff --git a/src/expressions/shift_expr.ml b/src/expressions/shift_expr.ml new file mode 100644 index 0000000..17cce95 --- /dev/null +++ b/src/expressions/shift_expr.ml @@ -0,0 +1,67 @@ +(* +This file is part of licht. + +licht is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +licht is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with licht. If not, see . +*) + +module Shift_Ref = struct + + type 'a t = (int * int) -> ScTypes.Refs.t + type 'a obs = (int * int) -> ScTypes.Refs.t + + let _shift (vector_x, vector_y) ((x, y), (fixed_x, fixed_y)) = + let x' = if fixed_x then x else x + vector_x + and y' = if fixed_y then y else y + vector_y in + (x', y'), (fixed_x, fixed_y) + + let cell t shift = + ScTypes.Refs.cell (_shift shift t) + + + let range c1 c2 shift = + ScTypes.Refs.range (_shift shift c1) (_shift shift c2) + + let observe elem shift = elem shift + +end + +module Shift_Expr = struct + + type t = (int * int) -> ScTypes.Expr.t + type obs = (int * int) -> ScTypes.Expr.t + + module R = Shift_Ref + module T = Id_type + + let observe f x = f x + + let value t vector = ScTypes.Expr.value (T.observe t) + + let ref r vector = ScTypes.Expr.ref (R.observe r vector) + + let call0 ident vector = ScTypes.Expr.call0 ident + + let call1 ident p1 vector = ScTypes.Expr.call1 ident (observe p1 vector) + + let call2 ident p1 p2 vector = ScTypes.Expr.call2 ident (observe p1 vector) (observe p2 vector) + + let call3 ident p1 p2 p3 vector = ScTypes.Expr.call3 ident (observe p1 vector) (observe p2 vector) (observe p3 vector) + + let expression e vector = ScTypes.Expr.expression (observe e vector) + + let callN ident (params: t list) vector = ScTypes.Expr.callN ident (List.map (fun x -> observe x vector) params) + +end + +include Shift_Expr diff --git a/src/expressions/show_expr.ml b/src/expressions/show_expr.ml old mode 100755 new mode 100644 index c283162..a191d2d --- a/src/expressions/show_expr.ml +++ b/src/expressions/show_expr.ml @@ -24,27 +24,26 @@ module Show_Expr module T = T module R = R - type t = unit - type repr = UTF8.Buffer.buffer -> unit + type t = UTF8.Buffer.buffer -> unit type obs = UTF8.Buffer.buffer -> unit let observe buffer value = buffer value - let value v () buffer = T.observe v buffer + let value v buffer = T.observe v buffer - let ref r () buffer = R.observe r buffer + let ref r buffer = R.observe r buffer - let call0 ident () buffer = + let call0 ident buffer = let utf8ident = UTF8.to_utf8string ident in UTF8.Printf.bprintf buffer "%s()" utf8ident - let call1 ident p1 () buffer = + let call1 ident p1 buffer = let utf8ident = UTF8.to_utf8string ident in UTF8.Printf.bprintf buffer "%s(%a)" utf8ident (fun x b -> observe b x) p1 - let call2 ident p1 p2 () buffer = + let call2 ident p1 p2 buffer = let utf8ident = UTF8.to_utf8string ident in begin match utf8ident with | "+" | "*" | "-" | "/" | "^" | "=" @@ -60,7 +59,7 @@ module Show_Expr (fun x b -> observe b x) p2 end - let call3 ident p1 p2 p3 () buffer = + let call3 ident p1 p2 p3 buffer = let utf8ident = UTF8.to_utf8string ident in UTF8.Printf.bprintf buffer "%s(%a;%a;%a)" utf8ident @@ -68,11 +67,11 @@ module Show_Expr (fun x b -> observe b x) p2 (fun x b -> observe b x) p3 - let callN ident (params: repr list) () buffer = + let callN ident (params: t list) buffer = UTF8.Buffer.add_string buffer ident; Tools.List.printb ~sep:(u";") (fun buffer value -> value buffer) buffer params - let expression e () buffer = + let expression e buffer = UTF8.Printf.bprintf buffer "(%a)" (fun x b -> b x) e diff --git a/src/expressions/sym_expr.ml b/src/expressions/sym_expr.ml old mode 100755 new mode 100644 index 4f5d6a6..843b8a4 --- a/src/expressions/sym_expr.ml +++ b/src/expressions/sym_expr.ml @@ -23,26 +23,24 @@ module type SYM_EXPR = sig type t - type repr - type obs - val value : 'a T.t -> t -> repr + val value : 'a T.t -> t - val ref : 'a R.t -> t -> repr + val ref : 'a R.t -> t - val call0 : UTF8.t -> t -> repr + val call0 : UTF8.t -> t - val call1 : UTF8.t -> repr -> t -> repr + val call1 : UTF8.t -> t -> t - val call2 : UTF8.t -> repr -> repr -> t -> repr + val call2 : UTF8.t -> t -> t -> t - val call3 : UTF8.t -> repr -> repr -> repr -> t -> repr + val call3 : UTF8.t -> t -> t -> t -> t - val callN: UTF8.t -> repr list -> t -> repr + val callN: UTF8.t -> t list -> t - val expression : repr -> t -> repr + val expression : t -> t - val observe : repr -> obs + val observe : t -> obs end -- cgit v1.2.3