diff options
Diffstat (limited to 'evaluator.ml')
| -rwxr-xr-x | evaluator.ml | 235 |
1 files changed, 90 insertions, 145 deletions
diff --git a/evaluator.ml b/evaluator.ml index b390771..c17a397 100755 --- a/evaluator.ml +++ b/evaluator.ml @@ -5,16 +5,12 @@ module Data = struct (** Data format *)
-type _ dataFormat =
- | Date: D.Num.t dataFormat (* Date *)
- | Number: D.Num.t dataFormat (* Number *)
- | String: UTF8.t dataFormat (* String result, there is only one representation *)
- | Bool: D.Bool.t dataFormat (* Boolean result *)
+type 'a dataFormat = 'a ScTypes.dataFormat
let most_generic_format: type a. a dataFormat -> a dataFormat -> a dataFormat =
begin fun a b -> match a, b with
- | Number, x -> x
- | x, Number -> x
+ | ScTypes.Number, x -> x
+ | x, ScTypes.Number -> x
| x, _ -> x
end
@@ -27,13 +23,11 @@ type _ typ = | String: UTF8.t typ
| List: 'a typ -> 'a list typ
-let typ_of_format:
-type a. a dataFormat -> a typ =
-function
- | Date -> Num
- | Number -> Num
- | String -> String
- | Bool -> Bool
+let typ_of_format: type a. a ScTypes.dataFormat -> a typ = function
+ | ScTypes.Date -> Num
+ | ScTypes.Number -> Num
+ | ScTypes.String -> String
+ | ScTypes.Bool -> Bool
let rec compare_typ:
type a b. a typ -> b typ -> (a, b) T.cmp =
@@ -62,57 +56,35 @@ 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 dataFormat = function
- | Num -> Date
- | String -> String
- | Bool -> Bool
+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
-(** Results format.
- Any value which can be encoded with different representation requires as
- many format than there are representations for this value.
-*)
-
-type _ result =
- | Numeric: D.Num.t result (* Any numeric format : the representation depends from the inputs *)
- | Date: D.Num.t result (* Date *)
- | Number: D.Num.t result (* Number *)
- | String: UTF8.t result (* String result, there is only one representation *)
- | Bool: D.Bool.t result (* Boolean result *)
+type 'a returnType = 'a ScTypes.returnType
-let specialize_result: type a. a result -> a dataFormat -> a result =
+let specialize_result: type a. a ScTypes.returnType -> a ScTypes.dataFormat -> a ScTypes.returnType =
begin fun a b -> match a, b with
- | Date, _ -> Date
- | _, Date -> Date
+ | ScTypes.Num (Some ScTypes.Date) as _1, _ -> _1
+ | _, ScTypes.Date -> ScTypes.Num (Some ScTypes.Date)
| x, y -> x
end
-let typ_of_result: type a. a result -> a typ = function
- | Numeric -> Num
- | Number -> Num
- | Date -> Num
- | Bool -> Bool
- | String -> String
-
-let rec compare_result: type a b. a result -> b result -> (a, b) T.cmp = begin fun a b ->
- match a, b with
- | Bool, Bool -> T.Eq
- | Numeric, Numeric-> T.Eq
- | String, String -> T.Eq
- | Number, Number -> T.Eq
- | Date, Date -> T.Eq
- | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt
+let typ_of_result: type a. a ScTypes.returnType -> a typ = function
+ | ScTypes.Num _ -> Num
+ | ScTypes.Bool -> Bool
+ | ScTypes.Str -> String
-end
(*** Values definitions *)
type 'a value =
| Bool: D.Bool.t -> D.Bool.t value
- | Num: D.Num.t dataFormat * D.Num.t -> D.Num.t value
+ | Num: D.Num.t ScTypes.dataFormat * D.Num.t -> D.Num.t value
| String: UTF8.t -> UTF8.t value
- | List: 'a dataFormat * 'a list -> 'a list value
- | List2: 'a dataFormat * 'a list list -> 'a list list value
+ | List: 'a ScTypes.dataFormat * 'a list -> 'a list value
+ | Matrix: 'a ScTypes.dataFormat * 'a list list -> 'a list list value
(** Get the value out of the box *)
let get_value_content: type a. a value -> a = function
@@ -120,17 +92,7 @@ let get_value_content: type a. a value -> a = function | Num (_, n) -> n
| String s -> s
| List (t, l) -> l
- | List2 (t, l) -> l
-
-(** Create a value from a known type and an unboxed value *)
-let build_value: type a. a dataFormat -> a -> a value = begin fun format content ->
- match (typ_of_format format), content with
- | Unit, _ -> raise Errors.TypeError
- | Bool, x -> Bool x
- | Num, x -> Num (format, x)
- | String, s -> String s
- | List t, l -> raise Errors.TypeError
-end
+ | Matrix (t, l) -> l
(* Extract the type from a boxed value *)
let type_of_value: type a. a value -> a typ = function
@@ -138,54 +100,53 @@ let type_of_value: type a. a value -> a typ = function | Num (n, _) -> Num
| String s -> String
| List (t, l) -> List (typ_of_format t)
- | List2 (t, l) -> List (List (typ_of_format t))
+ | Matrix (t, l) -> List (List (typ_of_format t))
-let format_of_value: type a. a value -> a dataFormat = function
- | Bool b -> Bool
+let format_of_value: type a. a value -> a ScTypes.dataFormat = function
+ | Bool b -> ScTypes.Bool
| Num (f, _) -> f
- | String s -> String
+ | String s -> ScTypes.String
| List (t, l) -> raise Errors.TypeError
- | List2 (t, l) -> raise Errors.TypeError
+ | Matrix (t, l) -> raise Errors.TypeError
- let inject':
- type a. a result -> (unit -> a dataFormat) -> a -> a value =
+let inject':
+ type a. a ScTypes.returnType -> (unit -> a ScTypes.dataFormat) -> a -> a value =
fun resultFormat f res -> begin match resultFormat, res with
- | Bool, x -> Bool x
- | Numeric, x -> Num (f (), x)
- | Date, x -> Num(Date, x)
- | Number, x -> Num(Number, x)
- | String, s -> String s
+ | ScTypes.Bool, x -> Bool x
+ | ScTypes.Str, s -> String s
+ | ScTypes.Num None, x -> Num (f (), x)
+ | ScTypes.Num (Some v), x -> Num(v, x)
end
-let compare_format: type a b. a typ -> a result -> b value -> a result = begin
+let compare_format: type a b. a typ -> a ScTypes.returnType -> b value -> a ScTypes.returnType = begin
fun init_typ currentResult value ->
-(* If the argument as the same type as the result format, just the most specialized *)
-match compare_typ init_typ (type_of_value value) with
- | T.Eq -> begin match value with
- | Bool b -> Bool
- | String s -> String
- | Num (f, v) -> specialize_result currentResult f
- (* There is no possibility to get init_typ as List typ*)
- | List (f, v) -> raise Errors.TypeError
- | List2 (f, v) -> raise Errors.TypeError
- end
- (* The types differ, handle the special cases for Lists *)
- | _ ->
- begin match value with
- | List (f, v) ->
- begin match compare_typ init_typ (typ_of_format f) with
- | T.Eq -> specialize_result currentResult f
- | _ -> currentResult
+ (* If the argument as the same type as the result format, just select the most specialized *)
+ match compare_typ init_typ (type_of_value value) with
+ | T.Eq -> begin match value with
+ | 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*)
+ | List (f, v) -> raise Errors.TypeError
+ | Matrix (f, v) -> raise Errors.TypeError
end
- | List2 (f, v) ->
- begin match compare_typ init_typ (typ_of_format f) with
- | T.Eq -> specialize_result currentResult f
+ (* The types differ, handle the special cases for Lists *)
+ | _ ->
+ begin match value with
+ | List (f, v) ->
+ begin match compare_typ init_typ (typ_of_format f) with
+ | T.Eq -> specialize_result currentResult f
+ | _ -> currentResult
+ end
+ | Matrix (f, v) ->
+ begin match compare_typ init_typ (typ_of_format f) with
+ | T.Eq -> specialize_result currentResult f
+ | _ -> currentResult
+ end
| _ -> currentResult
end
- | _ -> currentResult
- end
-end
+ end
end
@@ -201,28 +162,27 @@ type existencialResult = The most specialized format take over the others.
*)
let guess_format_result:
-type a. a Data.result -> existencialResult list -> unit -> a Data.dataFormat =
+type a. a ScTypes.returnType -> existencialResult list -> unit -> a Data.dataFormat =
begin fun init_value values () ->
let init_typ:a Data.typ = Data.typ_of_result init_value in
(* fold over the arguments, and check if they have the same format *)
- let compare_format: a Data.result -> existencialResult -> a Data.result =
+ let compare_format: a ScTypes.returnType -> existencialResult -> a ScTypes.returnType =
fun currentResult (Result value) ->
Data.compare_format init_typ currentResult value in
begin match List.fold_left compare_format init_value values with
- | Data.String -> Data.String
- | Data.Bool -> Data.Bool
- | Data.Number -> Data.Number
- | Data.Date -> Data.Date
- | Data.Numeric -> Data.Number
+ | ScTypes.Str -> ScTypes.String
+ | ScTypes.Bool -> ScTypes.Bool
+ | ScTypes.Num None-> ScTypes.Number
+ | ScTypes.Num (Some x)-> x
end
end
let inject:
-type a. a Data.result -> (unit -> a Data.dataFormat) -> a -> existencialResult =
+type a. a Data.returnType -> (unit -> a Data.dataFormat) -> a -> existencialResult =
fun resultFormat f res ->
let (x:a Data.value) = Data.inject' resultFormat f res in
Result x
@@ -242,7 +202,6 @@ let register3 name (typ1, typ2, typ3) result f = let call name args = begin
let name' = UTF8.to_utf8string name in
begin try match args with
-
| [] ->
let C.Fn1(ret, f) = C.find_function !catalog name' (C.T1 Data.Unit) in
inject ret (fun () -> raise Errors.TypeError) (f ())
@@ -278,19 +237,19 @@ let repr mapper value = begin (** Extract the value from a raw type.
If the value is Undefined, raise an exception.
*)
- let extract_value = begin function
- | ScTypes.Num (n,s) -> Result (Data.Num (Data.Number, (D.Num.of_num n)))
- | ScTypes.Bool b -> Result (Data.Bool b)
- | ScTypes.Date d -> Result (Data.Num (Data.Date, (D.Num.of_num d)))
- | ScTypes.Str s -> Result (Data.String s)
+ let extract_value : ScTypes.result -> existencialResult = begin function
+ | ScTypes.Result (ScTypes.Num (f, n)) -> Result (Data.Num (f, n))
+ | ScTypes.Result (ScTypes.Bool b) -> Result (Data.Bool b)
+ | ScTypes.Result (ScTypes.Str s) -> Result (Data.String s)
+ | ScTypes.Error x -> raise x
end in
- let add_elem: type a. a Data.typ -> a list * a Data.dataFormat -> ScTypes.types option -> a list * a Data.dataFormat =
+ 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 (Data.Number, (D.Num.nan)))
+ | 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), []))
@@ -304,26 +263,6 @@ let repr mapper value = begin end
end in
- (* Return the result for any expression as an ScTypes.types result *)
- let rec get_repr: type a. a Data.value -> ScTypes.types = begin function
- | Data.Bool b -> ScTypes.Bool b
- | Data.Num (format, n) -> begin match format with
- | Data.Number -> ScTypes.Num (D.Num.to_num n, None)
- | Data.Date -> ScTypes.Date (D.Num.to_num n)
- | _ -> raise Errors.TypeError (* This pattern could be refuted *)
- end
- | Data.String s -> ScTypes.Str s
- | Data.List (t, l) ->
- List.hd l (* Extract the first element *)
- |> Data.build_value t (* Convert it in boxed value *)
- |> get_repr (* Return it's representation *)
- | Data.List2 (t, l) ->
- List.hd l (* Extract the first element *)
- |> List.hd
- |> Data.build_value t (* Convert it in boxed value *)
- |> get_repr (* Return it's representation *)
- 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
@@ -357,19 +296,25 @@ let repr mapper value = begin 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.List2 (format, elems))
+ Result (Data.Matrix (format, elems))
end
(* Evaluate the expression *)
| ScTypes.Expression e -> extract e
- | ScTypes.Value v -> extract_value v
+ | ScTypes.Value v -> extract_value (ScTypes.Result v)
| ScTypes.Call (name, args) ->
let args' = List.map extract args in
call name args'
end
in
- let Result r = extract value in
- get_repr r
+ let Result r = (extract value) in
+
+ begin match r with
+ | Data.Bool b -> ScTypes.Result (ScTypes.Bool b)
+ | Data.Num (format, n) -> ScTypes.Result (ScTypes.Num (format, n))
+ | Data.String s -> ScTypes.Result (ScTypes.Str s)
+ | _ -> raise Errors.TypeError
+ end
end
let wrap f =
@@ -380,13 +325,13 @@ let wrap f = (* Register the standard functions *)
-type 'a result = 'a Data.result
+type 'a returnType = 'a ScTypes.returnType
-let f_num: DataType.Num.t Data.result = Data.Numeric
-let f_date: DataType.Num.t Data.result = Data.Date
-let f_number: DataType.Num.t Data.result = Data.Number
-let f_string: DataType.String.t Data.result = Data.String
-let f_bool: DataType.Bool.t Data.result = Data.Bool
+let f_num = ScTypes.f_num
+let f_date = ScTypes.f_date
+let f_number = ScTypes.f_number
+let f_string = ScTypes.f_string
+let f_bool = ScTypes.f_bool
module Make_Compare(C: D.COMPARABLE) = struct
@@ -468,7 +413,7 @@ let () = begin (* Build a date *)
register3 "date" (t_int, t_int, t_int) f_date (
fun year month day ->
- Tools.Date.get_julian_day
+ Date.get_julian_day
(Num.int_of_num @@ Num.floor_num @@ D.Num.to_num year)
(Num.int_of_num @@ Num.floor_num @@ D.Num.to_num month)
(Num.int_of_num @@ Num.floor_num @@ D.Num.to_num day)
|