aboutsummaryrefslogtreecommitdiff
path: root/scTypes.ml
diff options
context:
space:
mode:
authorSébastien Dailly <sebastien@chimrod.com>2017-11-24 09:22:24 +0100
committerSébastien Dailly <sebastien@chimrod.com>2017-11-24 09:23:38 +0100
commita6b5a6bdd138a5ccc6827bcc73580df1e9218820 (patch)
treeff577395c1a5951a61a7234322f927f6ead5ee29 /scTypes.ml
parentecb6fd62c275af03a07d892313ab3914d81cd40e (diff)
Moved all the code to src directory
Diffstat (limited to 'scTypes.ml')
-rwxr-xr-xscTypes.ml354
1 files changed, 0 insertions, 354 deletions
diff --git a/scTypes.ml b/scTypes.ml
deleted file mode 100755
index 48e4d3c..0000000
--- a/scTypes.ml
+++ /dev/null
@@ -1,354 +0,0 @@
-(** 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
-