aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xevaluator.ml72
-rwxr-xr-x[-rw-r--r--]scTypes.ml111
-rwxr-xr-x[-rw-r--r--]scTypes.mli21
-rwxr-xr-xtools.ml2
4 files changed, 128 insertions, 78 deletions
diff --git a/evaluator.ml b/evaluator.ml
index 46123cb..0d8c0f7 100755
--- a/evaluator.ml
+++ b/evaluator.ml
@@ -29,8 +29,7 @@ let typ_of_format: type a. a ScTypes.dataFormat -> a typ = function
| ScTypes.String -> String
| ScTypes.Bool -> Bool
-let rec compare_typ:
-type a b. a typ -> b typ -> (a, b) T.cmp =
+let rec compare_typ: type a b. a typ -> b typ -> (a, b) T.cmp =
begin fun a b ->
match a, b with
| Unit, Unit -> T.Eq
@@ -56,13 +55,6 @@ fun printer typ -> match typ with
| List t -> Format.fprintf printer "List[%a]"
print_typ t
-let default_format_for_type: type a. a typ -> a ScTypes.dataFormat = function
- | Num -> ScTypes.Date
- | String -> ScTypes.String
- | Bool -> ScTypes.Bool
- | List _ -> raise Errors.TypeError
- | Unit -> raise Errors.TypeError
-
type 'a returnType = 'a ScTypes.returnType
let specialize_result: type a. a ScTypes.returnType -> a ScTypes.dataFormat -> a ScTypes.returnType =
@@ -127,7 +119,7 @@ fun init_typ currentResult value ->
| Bool b -> ScTypes.Bool
| String s -> ScTypes.Str
| Num (f, v) -> specialize_result currentResult f
- (* There is no possibility to get init_typ as List typ*)
+ (* There is no possibility to get init_typ as List typ *)
| List (f, v) -> raise Errors.TypeError
| Matrix (f, v) -> raise Errors.TypeError
end
@@ -244,25 +236,6 @@ let repr mapper value = begin
| ScTypes.Error x -> raise x
end in
- let add_elem: type a. a Data.typ -> a list * a Data.dataFormat -> ScTypes.result option -> a list * a Data.dataFormat =
- begin fun type_of (result, format_of) next ->
- let Result r = match next with
- | Some x -> extract_value x
- | None -> begin match type_of with
- | Data.Num -> Result (Data.Num (ScTypes.Number, D.Num.nan))
- | Data.Bool -> Result (Data.Bool false)
- | Data.String -> Result (Data.String (UTF8.empty))
- | Data.List x -> Result (Data.List ((Data.default_format_for_type x), []))
- | Data.Unit -> raise Errors.TypeError
- end in
- begin match Data.compare_typ type_of (Data.type_of_value r) with
- | T.Eq ->
- let l' = (Data.get_value_content r)::result in
- l' , (Data.most_generic_format (Data.format_of_value r) format_of)
- | _ -> raise Errors.TypeError
- end
- end in
-
(** Extract the value from an expression.
[extract typ expr] will evaluate the expression and return it. If the
result cannot be evaluated (because of references pointing to missing
@@ -270,44 +243,27 @@ let repr mapper value = begin
*)
let rec extract = begin function
(* For a reference to an external we first extract the value pointed *)
- | ScTypes.Ref r ->
- begin match mapper r with
- | ScTypes.Refs.Single v ->
- begin match v with
- | None -> raise Errors.TypeError
- | Some v -> extract_value v
+ | ScTypes.Ref r -> ScTypes.Refs.(
+ begin match ScTypes.Refs.get_content @@ mapper r with
+ | C (Value (format, f)) -> begin match format with
+ | ScTypes.Date -> Result (Data.Num (format, f))
+ | ScTypes.Number -> Result (Data.Num (format, f))
+ | ScTypes.String -> Result (Data.String f)
+ | ScTypes.Bool -> Result (Data.Bool f)
end
- | ScTypes.Refs.Array1 l ->
- (* Guess the list type from it's first defined element *)
- let Result r = extract_value (Tools.List.find_map (fun x -> x) l) in
- let format_of = Data.format_of_value r
- and type_of = Data.type_of_value r in
- (* Build the list with all the elements *)
- let elems, format = List.fold_left (add_elem type_of) ([], format_of) l in
- Result (Data.List (format, elems))
- | ScTypes.Refs.Array2 l ->
- (* Guess the list type from it's first defined element *)
- let Result r = extract_value (Tools.List.find_map2 (fun x -> x) l) in
-
- let format_of = Data.format_of_value r
- and type_of = Data.type_of_value r in
- (* Build the list with all the elements *)
- let elems, format = List.fold_left (fun (result, format_of) elems ->
- let elems, format = List.fold_left (add_elem type_of) ([], format_of) elems in
- elems::result, (Data.most_generic_format format_of format)
- ) ([], format_of) l in
- Result (Data.Matrix (format, elems))
- end
+ | C (List (format, l)) -> Result (Data.List (format, l))
+ | C (Matrix (format, l)) -> Result (Data.Matrix (format, l))
+ end)
(* Evaluate the expression *)
| ScTypes.Expression e -> extract e
| ScTypes.Value v -> extract_value (ScTypes.Result v)
| ScTypes.Call (name, args) ->
- let args' = List.map extract args in
+ let args' = List.map extract args in
call name args'
end
in
- let Result r = (extract value) in
+ let Result r = ((extract[@tailrec]) value) in
begin match r with
| Data.Bool b -> ScTypes.Result (ScTypes.boolean b)
| Data.String s -> ScTypes.Result (ScTypes.string s)
diff --git a/scTypes.ml b/scTypes.ml
index ff0af83..f79b4ef 100644..100755
--- a/scTypes.ml
+++ b/scTypes.ml
@@ -8,8 +8,6 @@ type cell = Cell.t
type ident = UTF8.t
-type 'a number_format = (float -> 'a, Format.formatter, unit) format
-
type _ dataFormat =
| Date: DataType.Num.t dataFormat (* Date *)
| Number: DataType.Num.t dataFormat (* Number *)
@@ -53,18 +51,6 @@ 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 typeContainer =
- | Value: 'a types -> typeContainer
-
-let guess_format_result:
- type a. a returnType -> typeContainer list -> (a -> a types) =
- fun return params -> begin match return with
- | Str -> fun value -> Str value
- | Bool -> fun value -> Bool value
- | Num (Some x) -> fun value -> Num (x, value)
- | Num None -> fun value -> Num (Number, value)
-end
-
type refs =
| Cell of cell (** A cell *)
| Range of cell * cell (** An area of cells *)
@@ -118,6 +104,32 @@ module Type = struct
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
+
+ (*
+ let guess_format_result:
+ type a. a returnType -> t list -> (a -> a types) =
+ fun return params -> begin match return with
+ | Str -> fun value -> Str value
+ | Bool -> fun value -> Bool value
+ | Num (Some x) -> fun value -> Num (x, value)
+ | Num None -> fun value -> Num (Number, value)
+ end
+ *)
+
+ let default_value_for: type a. a dataFormat -> a = function
+ | Date -> DataType.Num.nan
+ | Number -> DataType.Num.nan
+ | Bool -> false
+ | String -> UTF8.empty
+
end
module Refs = struct
@@ -178,6 +190,77 @@ module Refs = struct
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
+
+ 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
+
+ (** 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, (Type.default_value_for format)::elements
+ | Some (Error x) -> raise x
+ | Some (Result r) ->
+ let Type.Value (format', element) = Type.get_content r in
+ let Eq = compare_format format format' in
+ let new_format = if (priority format) < (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
diff --git a/scTypes.mli b/scTypes.mli
index 5e5b378..de0d6f2 100644..100755
--- a/scTypes.mli
+++ b/scTypes.mli
@@ -6,8 +6,6 @@ type cell = (int * int) * (bool * bool)
type ident = UTF8.t
-type 'a number_format = (float -> 'a, Format.formatter, unit) format
-
type 'a dataFormat =
| Date: DataType.Num.t dataFormat (* A date in julian day *)
| Number: DataType.Num.t dataFormat (* Number *)
@@ -35,9 +33,6 @@ val string: DataType.String.t -> DataType.String.t types
val boolean: DataType.Bool.t -> DataType.Bool.t types
val date: DataType.Num.t -> DataType.Num.t types
-type typeContainer =
- | Value: 'a types -> typeContainer
-
(** Numeric (any format) *)
val f_num: DataType.Num.t returnType
@@ -72,6 +67,8 @@ type result =
module Type : sig
+ type t = Value: 'a dataFormat * 'a -> t
+
val (=) : 'a types -> 'b types -> bool
val show: UTF8.Buffer.buffer -> 'a types -> unit
@@ -91,6 +88,20 @@ module Refs : sig
val shift: (int * int) -> refs -> refs
+ 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
+
+ (** extract the content from a range.
+
+ May raise Errors.TypeError if the range cannot be unified.
+ *)
+ val get_content : result option range -> refContent
+
end
val show_expr: UTF8.Buffer.buffer -> expression -> unit
diff --git a/tools.ml b/tools.ml
index 45c9bab..53b1c15 100755
--- a/tools.ml
+++ b/tools.ml
@@ -143,7 +143,7 @@ module List = struct
| [] -> raise Not_found
| hd::tl -> begin match f hd with
| Some x -> x
- | None -> find_map f tl
+ | None -> (find_map[@tailrec]) f tl
end
end