aboutsummaryrefslogtreecommitdiff
path: root/evaluator.ml
diff options
context:
space:
mode:
Diffstat (limited to 'evaluator.ml')
-rwxr-xr-xevaluator.ml110
1 files changed, 29 insertions, 81 deletions
diff --git a/evaluator.ml b/evaluator.ml
index 8862b3a..a5f3380 100755
--- a/evaluator.ml
+++ b/evaluator.ml
@@ -50,24 +50,12 @@ fun printer typ -> match typ with
type 'a returnType = 'a ScTypes.returnType
-let specialize_result: type a. a ScTypes.returnType -> a ScTypes.dataFormat -> a ScTypes.returnType =
- begin fun a b -> match a, b with
- | 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 ScTypes.returnType -> a typ = function
- | ScTypes.Num _ -> Num
- | ScTypes.Bool -> Bool
- | ScTypes.Str -> String
-
(*** Values definitions *)
type 'a value =
| Bool: D.Bool.t -> D.Bool.t value
| Num: D.Num.t ScTypes.dataFormat * D.Num.t -> D.Num.t value
- | String: UTF8.t -> UTF8.t value
+ | String: UTF8.t -> UTF8.t value
| List: 'a ScTypes.dataFormat * 'a list -> 'a list value
| Matrix: 'a ScTypes.dataFormat * 'a list list -> 'a list list value
@@ -87,45 +75,6 @@ let type_of_value: type a. a value -> a typ = function
| List (t, l) -> List (typ_of_format t)
| Matrix (t, l) -> List (List (typ_of_format t))
-let inject':
- type a. a ScTypes.returnType -> (unit -> a ScTypes.dataFormat) -> a -> a value =
- fun resultFormat f res -> begin match resultFormat, res with
- | 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 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 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
- (* 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
- end
-
end
module C = Catalog.Make(Data)
@@ -142,34 +91,29 @@ let repr = C.repr
type existencialResult =
| Result : 'a Data.value -> existencialResult [@@unboxed]
-(** Guess the format to use for the result function from the arguments given.
- The most specialized format take over the others.
-*)
-let guess_format_result:
-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 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
- | ScTypes.Str -> ScTypes.String
- | ScTypes.Bool -> ScTypes.Bool
- | ScTypes.Num None-> ScTypes.Number
- | ScTypes.Num (Some x)-> x
+let inject:
+type a. a Data.dataFormat -> a -> existencialResult = fun resultFormat res ->
+ begin match resultFormat with
+ | ScTypes.Bool -> Result (Data.Bool res)
+ | ScTypes.String -> Result (Data.String res)
+ | ScTypes.Number -> Result (Data.Num (resultFormat, res))
+ | ScTypes.Date -> Result (Data.Num (resultFormat, res))
end
-end
-let inject:
-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
+(** Extract the format from a list of results *)
+let build_format_list ll () =
+
+ List.map (fun (Result x) ->
+ begin match x with
+ | Data.Bool _ -> ScTypes.DataFormat.F (ScTypes.Bool)
+ | Data.Num (x, _) -> ScTypes.DataFormat.F x
+ | Data.String _ -> ScTypes.DataFormat.F (ScTypes.String)
+ | Data.List (f, _) -> ScTypes.DataFormat.F f
+ | Data.Matrix (f, _) -> ScTypes.DataFormat.F f
+ end
+ ) ll
+
let register0 name returnType f =
catalog := C.register !catalog name (C.T1(Data.Unit)) (C.Fn1 (returnType, f))
@@ -188,22 +132,26 @@ let call name args = begin
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 ())
+ let returnType = ScTypes.DataFormat.guess_format_result ret (fun () -> raise Errors.TypeError) in
+ inject returnType (f ())
| (Result p1)::[] ->
let C.Fn1(ret, f) =
C.find_function !catalog name' (C.T1 (Data.type_of_value p1)) in
- inject ret (guess_format_result ret args) (f (Data.get_value_content p1))
+ let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in
+ inject returnType (f (Data.get_value_content p1))
| (Result p1)::(Result p2)::[] ->
let C.Fn2(ret, f) =
C.find_function !catalog name' (C.T2 (Data.type_of_value p1, Data.type_of_value p2)) in
- inject ret (guess_format_result ret args) (f (Data.get_value_content p1) (Data.get_value_content p2))
+ let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in
+ inject returnType (f (Data.get_value_content p1) (Data.get_value_content p2))
| (Result p1)::(Result p2)::(Result p3)::[] ->
let C.Fn3(ret, f) =
C.find_function !catalog name' (C.T3 (Data.type_of_value p1, Data.type_of_value p2, Data.type_of_value p3)) in
- inject ret (guess_format_result ret args) (f (Data.get_value_content p1) (Data.get_value_content p2) (Data.get_value_content p3))
+ let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in
+ inject returnType (f (Data.get_value_content p1) (Data.get_value_content p2) (Data.get_value_content p3))
| _ -> raise Not_found
with Not_found ->
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-18 13:35:00 +0000