From 824f2987d47e87d58ee2a4a96d7be417aad6aeab Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Wed, 31 Jan 2018 13:20:20 +0100 Subject: API refactoring : made the GADT abstract, provide contructor for each case, and deported the expression with evaluation with module functors --- src/scTypes.ml | 387 +++++++++++++++++++-------------------------------------- 1 file changed, 130 insertions(+), 257 deletions(-) (limited to 'src/scTypes.ml') diff --git a/src/scTypes.ml b/src/scTypes.ml index fc6dd1f..ef39af3 100755 --- a/src/scTypes.ml +++ b/src/scTypes.ml @@ -4,87 +4,29 @@ let u = UTF8.from_utf8string exception Error -type cell = Cell.t - -type ident = UTF8.t - -type _ dataFormat = - | Date: DataType.Num.t dataFormat (* Date *) - | Number: DataType.Num.t dataFormat (* Number *) - | String: DataType.String.t dataFormat(* String *) - | Bool: DataType.Bool.t dataFormat (* Boolean *) - -type numericType = - | Date - | Number - -let get_numeric_type: DataType.Num.t dataFormat -> numericType = function - | Date -> Date - | Number -> Number - -type 'a types = - | Num : DataType.Num.t dataFormat * DataType.Num.t -> DataType.Num.t types (** A number *) - | Str : DataType.String.t -> DataType.String.t types (** A string *) - | Bool : DataType.Bool.t -> DataType.Bool.t types (** A boolean *) - -let number n = Num (Number, n) -let string s = Str s -let date d = Num (Date, d) -let boolean b = Bool b - - -type 'a returnType = - | Num : DataType.Num.t dataFormat option -> DataType.Num.t returnType (** A number *) - | Str : DataType.String.t returnType (** A string *) - | Bool : DataType.Bool.t returnType (** A boolean *) - - -let f_num: DataType.Num.t returnType = Num None -let f_date: DataType.Num.t returnType = Num (Some Date) -let f_number: DataType.Num.t returnType = Num (Some Number) -let f_string: DataType.String.t returnType = Str -let f_bool: DataType.Bool.t returnType = Bool - -type refs = - | Cell of cell (** A cell *) - | Range of cell * cell (** An area of cells *) - -type expression = - | Value : 'a types -> expression (** A direct value *) - | Ref : refs -> expression (** A reference to another cell *) - | Call : ident * expression list -> expression (** A call to a function *) - | Expression : expression -> expression (** An expression *) - -(** Result from a computation *) -type result = - | Result : 'a types -> result - | Error : exn -> result - module DataFormat = struct - type formats = F : 'a dataFormat -> formats [@@unboxed] + type _ t = + | Date: DataType.Num.t t (* Date *) + | Number: DataType.Num.t t (* Number *) + | String: DataType.String.t t(* String *) + | Bool: DataType.Bool.t t (* Boolean *) + + type formats = F : 'a t -> formats [@@unboxed] - let priority: type a. a dataFormat -> int = function + let priority: type a. a t -> int = function | Date -> 1 | Number -> 0 | String -> 0 | Bool -> 0 - let collect_format: DataType.Num.t dataFormat -> formats -> DataType.Num.t dataFormat = begin + let collect_format: DataType.Num.t t -> formats -> DataType.Num.t t = begin fun dataFormat -> function | F Date -> Date | _ -> dataFormat end - let guess_format_result: type a. a returnType -> (unit -> formats list) -> a dataFormat = - fun return params -> begin match return with - | Str -> String - | Bool -> Bool - | Num (Some x) -> x - | Num None -> List.fold_left collect_format Number (params ()) - end - - let default_value_for: type a. a dataFormat -> a = function + let default_value_for: type a. a t -> a = function | Date -> DataType.Num.zero | Number -> DataType.Num.zero | Bool -> false @@ -92,7 +34,7 @@ module DataFormat = struct type ('a, 'b) equality = Eq : ('a, 'a) equality - let compare_format: type a b. a dataFormat -> b dataFormat -> (a, b) equality = + let compare_format: type a b. a t -> b t -> (a, b) equality = fun a b -> begin match a, b with | Date, Date -> Eq | String, String -> Eq @@ -107,117 +49,44 @@ end module Type = struct - let (=) : type a b. a types -> b types -> bool = fun t1 t2 -> + type 'a t = + | Num : DataType.Num.t DataFormat.t * DataType.Num.t -> DataType.Num.t t (** A number *) + | Str : DataType.String.t -> DataType.String.t t (** A string *) + | Bool : DataType.Bool.t -> DataType.Bool.t t (** A boolean *) + + let number n = Num (Number, n) + let string s = Str s + let date d = Num (Date, d) + let boolean b = Bool b + + let (=) : type a b. a t -> b t -> bool = fun t1 t2 -> match t1, t2 with | Num (_, n1), Num (_, n2) -> DataType.Num.eq n1 n2 | Bool b1, Bool b2 -> b1 = b2 | Str s1, Str s2 -> s1 = s2 | _, _ -> false - (** Show a list of elements - *) - let rec show_list printer buffer = begin function - | [] -> () - | hd::[] -> - UTF8.Printf.bprintf buffer "%a" - printer hd - | hd::tl -> - UTF8.Printf.bprintf buffer "%a, " - printer hd; - show_list printer buffer tl - end - - let show: type a. UTF8.Buffer.buffer -> a types -> unit = fun buffer -> begin function - | Str x -> UTF8.Buffer.add_string buffer x - | Bool b -> UTF8.Printf.bprintf buffer "%B" b - | Num (Number, n) -> - if DataType.Num.is_integer n then - DataType.Num.to_int n - |> string_of_int - |> UTF8.from_utf8string - |> UTF8.Buffer.add_string buffer - else - let f = DataType.Num.to_float n - and to_b = UTF8.Format.formatter_of_buffer buffer in - ignore @@ UTF8.Format.fprintf to_b "%.2f" f; - Format.pp_print_flush to_b () - | Num (Date, n) -> - let y, m, d = DataType.Date.date_from_julian_day n in - UTF8.Printf.bprintf buffer "%d/%d/%d" y m d - end + module Eval(T:Sym_type.SYM_TYPE) = struct - let show_full: type a. UTF8.Buffer.buffer -> a types -> unit = fun buffer -> begin function - | Str x -> UTF8.Buffer.add_string buffer x - | Bool b -> UTF8.Printf.bprintf buffer "%B" b - | Num (Number, n) -> - if DataType.Num.is_integer n then - DataType.Num.to_int n - |> string_of_int - |> UTF8.from_utf8string - |> UTF8.Buffer.add_string buffer - else - let f = DataType.Num.to_float n - and to_b = UTF8.Format.formatter_of_buffer buffer in - ignore @@ UTF8.Format.fprintf to_b "%f" f; - Format.pp_print_flush to_b () - | Num (Date, n) -> - let y, m, d = DataType.Date.date_from_julian_day n in - UTF8.Printf.bprintf buffer "%d/%d/%d" y m d - end + let eval_type : type a. a t -> a T.t = function + | Str s -> T.str s + | Bool b -> T.bool b + | Num (f, n) -> + match f with + | DataFormat.Number -> T.num n + | DataFormat.Date -> T.date n - type t = - | Value: 'a dataFormat * 'a -> t + let eval t = T.observe (eval_type t) - let get_content : type a. a types -> t = begin function - | Num (format, data) -> Value (format, data) - | Str s -> Value (String, s) - | Bool b -> Value (Bool, b) end end module Refs = struct - type 'a range = - | Single of 'a - | Array1 of 'a list - | Array2 of 'a list list - - let collect = function - | Cell x -> Single (Pervasives.fst x) - | Range (fst, snd) -> - let (x1, y1) = Pervasives.fst fst - and (x2, y2) = Pervasives.fst snd in - let min_x = min x1 x2 - and max_x = max x1 x2 - and min_y = min y1 y2 - and max_y = max y1 y2 in - if (min_x = max_x) || (min_y = max_y) then ( - (* There is only a one dimension array *) - let elms = ref [] in - for x = min_x to max_x do - for y = min_y to max_y do - elms := (x, y)::!elms - done - done; - Array1 (!elms) - ) else ( - (* This a two-dimension array *) - let elmx = ref [] in - for x = min_x to max_x do - let elmy = ref [] in - for y = min_y to max_y do - elmy := (x, y)::!elmy - done; - elmx := !elmy::!elmx - done; - Array2 (!elmx) - ) - - let map f = function - | Single coord -> Single (f coord) - | Array1 values -> Array1 (List.map f values) - | Array2 values -> Array2 (List.map (List.map f) values) + type t = + | Cell of Cell.t (** A cell *) + | Range of Cell.t * Cell.t (** An area of cells *) let shift (vector_x, vector_y) ref = let _shift ((x, y), (fixed_x, fixed_y)) = @@ -228,74 +97,90 @@ module Refs = struct | Cell x -> Cell (_shift x) | Range (fst, snd) -> Range (_shift fst, _shift snd) - let show buffer = begin function - | Cell r -> UTF8.Buffer.add_string buffer @@ Cell.to_string r - | Range (f,t) -> - Tools.Tuple2.printb ~first:"" ~last:"" ~sep:":" Cell.to_buffer Cell.to_buffer buffer (f,t) + let cell c = Cell c + let range c1 c2 = Range (c1, c2) + + module Eval(R:Sym_ref.SYM_REF) = struct + + let eval_ref = function + | Cell c -> R.cell c + | Range(c1, c2) -> R.range c1 c2 + + let eval t = R.observe (eval_ref t) + end - type content = - | Value: 'a dataFormat * 'a -> content - | List: 'a dataFormat * 'a list -> content - | Matrix: 'a dataFormat * 'a list list -> content - - (** Add one element in a typed list. - - The function will raise Error.TypeError if the elements does not match - with the list type. - *) - let add_elem: type a b. a dataFormat * a list -> result option -> a dataFormat * a list = - fun (format, elements) result -> - begin match result with - | None -> format, (DataFormat.default_value_for format)::elements - | Some (Error x) -> raise x - | Some (Result r) -> - let Type.Value (format', element) = Type.get_content r in - let DataFormat.Eq = DataFormat.compare_format format format' in - let new_format = if (DataFormat.priority format) > (DataFormat.priority format') then - format - else - format' in - new_format, element::elements +end + +module Expr = struct + + type ident = UTF8.t + + type t = + | Value : 'a Type.t -> t (** A direct value *) + | Ref : Refs.t -> t (** A reference to another cell *) + | Call0 : ident -> t (** A call to a 0 arg function *) + | Call1 : ident * t -> t (** A call to a 1 arg function *) + | Call2 : ident * t * t -> t (** A call to a 2 arg function *) + | Call3 : ident * t * t * t -> t (** A call to a 3 arg function *) + | CallN : ident * t list -> t (** A call to a function *) + | Expression : t -> t (** An expression *) + + let value v = Value v + let ref r = Ref r + let call0 ident = Call0 ident + let call1 ident expr = Call1 (ident, expr) + let call2 ident expr1 expr2 = Call2(ident, expr1, expr2) + let call3 ident expr1 expr2 expr3 = Call3(ident, expr1, expr2, expr3) + let callN ident params = CallN(ident, params) + let expression e = Expression e + + let rec shift_exp vector = function + | Value v -> Value v + | Call0 ident -> Call0 ident + | Call1 (ident, p1) -> Call1 (ident, shift_exp vector p1) + | Call2 (ident, p1, p2) -> Call2 (ident, shift_exp vector p1, shift_exp vector p2) + | Call3 (ident, p1, p2, p3) -> Call3 (ident, shift_exp vector p1, shift_exp vector p2, shift_exp vector p3) + | CallN (ident, params) -> CallN (ident, List.map (shift_exp vector) params) + | Ref r -> Ref (Refs.shift vector r) + | Expression expr -> Expression (shift_exp vector expr) + + module Eval(E:Sym_expr.SYM_EXPR) = struct + + module T = Type.Eval(E.T) + module R = Refs.Eval(E.R) + + let eval e t = begin + + let rec eval_expr : t -> E.repr = function + | Ref r -> E.ref (R.eval_ref r) t + | Value v -> E.value (T.eval_type v) t + | Call0 ident -> E.call0 ident t + | Call1 (ident, p1) -> E.call1 ident (eval_expr p1) t + | Call2 (ident, p1, p2) -> E.call2 ident (eval_expr p1) (eval_expr p2) t + | Call3 (ident, p1, p2, p3) -> E.call3 ident (eval_expr p1) (eval_expr p2) (eval_expr p3) t + | CallN (ident, exprs) -> E.callN ident (List.map (fun x -> eval_expr x) exprs) t + | Expression e -> E.expression (eval_expr e) t + in + E.observe (eval_expr e) end - let get_content = begin function - | Single None -> raise Errors.TypeError - | Single (Some (Error x)) -> raise x - | Single (Some (Result r)) -> - let Type.Value (format, c) = Type.get_content r in - Value (format, c) - | Array1 l -> - (* Get the first element in the list in order to get the format *) - let Type.Value (format, _) = - begin match (Tools.List.find_map (fun x -> x) l) with - | Error x -> raise x - | Result r -> Type.get_content r - end in - (* Then build an unified list (if we can) *) - let format, values = List.fold_left add_elem (format, []) l in - List(format, List.rev values) - | Array2 l -> - (* Get the first element in the list *) - let Type.Value (format, _) = - begin match (Tools.List.find_map2 (fun x -> x) l) with - | Error x -> raise x - | Result r -> Type.get_content r - end in - (* Then build an unified list *) - let format, values = List.fold_left (fun (format, result) elems -> - let format, elems = List.fold_left add_elem (format, []) elems in - (format, List.rev (elems::result)) - )(format, []) l in - Matrix(format, List.rev values) end end +module TypeRepr = Type.Eval(Show_type) + module Result = struct + + (** Result from a computation *) + type t = + | Ok : 'a Type.t -> t + | Error : exn -> t + let (=) t1 t2 = match t1, t2 with - | Result v1, Result v2 -> Type.(=) v1 v2 + | Ok v1, Ok v2 -> Type.(=) v1 v2 | _, _ -> t1 = t2 let show = begin function @@ -308,45 +193,33 @@ module Result = struct u(Buffer.contents buffer) *) u"#Error" - | Result v -> + | Ok v -> let buffer = UTF8.Buffer.create 16 in - Type.show buffer v; + TypeRepr.eval v buffer; UTF8.Buffer.contents buffer end end -(** Represent an expression. - *) -let rec show_expr buffer : expression -> unit = begin function - | Value (Str x) -> - (** Print the value with quotes *) - UTF8.Printf.bprintf buffer "\"%s\"" (UTF8.to_utf8string x) - | Value v -> Type.show buffer v - | Ref r -> Refs.show buffer r - | Call (ident, params) -> - let utf8ident = UTF8.to_utf8string ident in - begin match utf8ident with - | "+" | "*" | "-" | "/" | "^" | "=" - | "<>" | "<=" | ">=" | "<" | ">" -> begin match params with - | v1::[] -> - UTF8.Printf.bprintf buffer "%s%a" - utf8ident - show_expr v1 - | v1::v2::[] -> - UTF8.Printf.bprintf buffer "%a%s%a" - show_expr v1 - utf8ident - show_expr v2 - | _ -> - UTF8.Buffer.add_string buffer ident; - Tools.List.printb ~sep:(u";") show_expr buffer params - end - | _ -> - UTF8.Buffer.add_string buffer ident; - Tools.List.printb ~sep:(u";") show_expr buffer params - end - | Expression expr -> - UTF8.Printf.bprintf buffer "(%a)" show_expr expr -end +module ReturnType = struct + + type 'a t = + | Num : DataType.Num.t DataFormat.t option -> DataType.Num.t t (** A number *) + | Str : DataType.String.t t (** A string *) + | Bool : DataType.Bool.t t (** A boolean *) + let f_num: DataType.Num.t t = Num None + let f_date: DataType.Num.t t = Num (Some Date) + let f_number: DataType.Num.t t = Num (Some Number) + let f_string: DataType.String.t t = Str + let f_bool: DataType.Bool.t t = Bool + + let guess_format_result: type a. a t -> (unit -> DataFormat.formats list) -> a DataFormat.t = + fun return params -> begin match return with + | Str -> DataFormat.String + | Bool -> DataFormat.Bool + | Num (Some x) -> x + | Num None -> List.fold_left DataFormat.collect_format DataFormat.Number (params ()) + end + +end -- cgit v1.2.3