1 files changed, 354 insertions, 0 deletions

diff --git a/src/scTypes.ml b/src/scTypes.ml
new file mode 100755
index 0000000..48e4d3c
--- /dev/null
+++ b/src/scTypes.ml
@@ -0,0 +1,354 @@
+(** All the types used in the spreadsheet. *)
+
+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]
+
+  let priority: type a. a dataFormat -> int = function
+    | Date   -> 1
+    | Number -> 0
+    | String -> 0
+    | Bool   -> 0
+
+  let collect_format: DataType.Num.t dataFormat -> formats -> DataType.Num.t dataFormat = 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
+    | Date -> DataType.Num.zero
+    | Number -> DataType.Num.zero
+    | Bool -> false
+    | String -> UTF8.empty
+
+  type ('a, 'b) equality = Eq : ('a, 'a) equality
+
+  let compare_format: type a b. a dataFormat -> b dataFormat -> (a, b) equality =
+    fun a b -> begin match a, b with
+    | Date, Date -> Eq
+    | String, String -> Eq
+    | Number, Number -> Eq
+    | Date, Number -> Eq
+    | Number, Date -> Eq
+    | Bool, Bool -> Eq
+    | _, _ -> raise Errors.TypeError
+    end
+
+end
+
+module Type = struct
+
+  let (=) : type a b. a types -> b types -> 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
+
+  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
+
+  type t =
+    | Value: 'a dataFormat * 'a -> 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)
+
+  let shift (vector_x, vector_y) ref =
+    let _shift ((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)
+    in match ref with
+    | 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)
+  end
+
+  type 'a content =
+    | Value: 'a dataFormat * 'a -> 'a content
+    | List: 'a dataFormat * 'a list -> 'a list content
+    | Matrix: 'a dataFormat * 'a list list -> 'a list list content
+
+  type refContent =
+    | C: 'a content -> refContent [@@unboxed]
+
+  (** 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
+
+  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 C (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
+    C (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
+    C (Matrix(format, List.rev values))
+  end
+
+end
+
+module Result = struct
+  let (=) t1 t2 =
+    match t1, t2 with
+    | Result v1, Result v2 -> Type.(=) v1 v2
+    | _, _ -> t1 = t2
+
+  let show = begin function
+    | Error x ->
+        (*
+        let buffer = Buffer.create 16 in
+        let b = Format.formatter_of_buffer buffer in
+        Errors.printf b x;
+        Format.pp_print_flush b ();
+        u(Buffer.contents buffer)
+        *)
+        u"#Error"
+    | Result v ->
+          let buffer = UTF8.Buffer.create 16 in
+          Type.show buffer v;
+          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
+