aboutsummaryrefslogtreecommitdiff
path: root/src/functions.ml
diff options
context:
space:
mode:
Diffstat (limited to 'src/functions.ml')
-rw-r--r--src/functions.ml276
1 files changed, 132 insertions, 144 deletions
diff --git a/src/functions.ml b/src/functions.ml
index 491d968..87cff58 100644
--- a/src/functions.ml
+++ b/src/functions.ml
@@ -19,59 +19,52 @@ module D = DataType
module T = Tools
type _ typ =
- | Unit: unit typ
- | Bool: D.Bool.t typ
- | Num: D.Num.t typ
- | String: UTF8.t typ
- | List: 'a typ -> 'a list typ
+ | Unit : unit typ
+ | Bool : D.Bool.t typ
+ | Num : D.Num.t typ
+ | String : UTF8.t typ
+ | List : 'a typ -> 'a list typ
let t_unit = Unit
-let t_bool: DataType.Bool.t typ = Bool
-let t_int: DataType.Num.t typ = Num
-let t_string: UTF8.t typ = String
-let t_list (t: 'a typ): 'a list typ = List t
+let t_bool : DataType.Bool.t typ = Bool
+let t_int : DataType.Num.t typ = Num
+let t_string : UTF8.t typ = String
+let t_list (t : 'a typ) : 'a list typ = List t
-let typ_of_format: type a. a ScTypes.DataFormat.t -> a typ = function
+let typ_of_format : type a. a ScTypes.DataFormat.t -> a typ = function
| ScTypes.DataFormat.Date -> Num
| ScTypes.DataFormat.Number -> Num
| ScTypes.DataFormat.String -> String
| ScTypes.DataFormat.Bool -> Bool
-
-let rec repr:
-type a. Format.formatter -> a typ -> unit =
-fun printer typ -> match typ with
- | Unit -> Format.fprintf printer "Unit"
- | Bool -> Format.fprintf printer "Bool"
- | Num -> Format.fprintf printer "Num"
+let rec repr : type a. Format.formatter -> a typ -> unit =
+ fun printer typ ->
+ match typ with
+ | Unit -> Format.fprintf printer "Unit"
+ | Bool -> Format.fprintf printer "Bool"
+ | Num -> Format.fprintf printer "Num"
| String -> Format.fprintf printer "String"
- | List t -> Format.fprintf printer "List[%a]"
- (repr[@tailcall]) t
-
-module C = Catalog.Make(struct
+ | List t -> Format.fprintf printer "List[%a]" (repr [@tailcall]) t
+module C = Catalog.Make (struct
let repr = repr
- 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
- | Bool, Bool -> T.Eq
- | Num, Num -> T.Eq
+ let rec compare_typ : type a b. a typ -> b typ -> (a, b) T.cmp =
+ fun a b ->
+ match (a, b) with
+ | Unit, Unit -> T.Eq
+ | Bool, Bool -> T.Eq
+ | Num, Num -> T.Eq
| String, String -> T.Eq
- | List l1, List l2 ->
- begin match compare_typ l1 l2 with
+ | List l1, List l2 -> (
+ match compare_typ l1 l2 with
| T.Lt -> T.Lt
| T.Eq -> T.Eq
- | T.Gt -> T.Gt
- end
- | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt
- end
+ | T.Gt -> T.Gt)
+ | x, y -> if T.Ex x > T.Ex y then T.Gt else T.Lt
type 'a t = 'a typ
-
type 'a returnType = 'a ScTypes.ReturnType.t
-
end)
let f_num = ScTypes.ReturnType.f_num
@@ -80,131 +73,126 @@ let f_number = ScTypes.ReturnType.f_number
let f_string = ScTypes.ReturnType.f_string
let f_bool = ScTypes.ReturnType.f_bool
-module Make_Compare(Comp: D.COMPARABLE) = struct
-
- let register t catalog = begin catalog
- |> C.register2 "=" (t, t) f_bool Comp.eq
+module Make_Compare (Comp : D.COMPARABLE) = struct
+ let register t catalog =
+ catalog
+ |> C.register2 "=" (t, t) f_bool Comp.eq
|> C.register2 "<>" (t, t) f_bool Comp.neq
- |> C.register2 ">" (t, t) f_bool Comp.gt
+ |> C.register2 ">" (t, t) f_bool Comp.gt
|> C.register2 ">=" (t, t) f_bool Comp.ge
- |> C.register2 "<" (t, t) f_bool Comp.lt
+ |> C.register2 "<" (t, t) f_bool Comp.lt
|> C.register2 "<=" (t, t) f_bool Comp.le
- end
-
end
-let built_in catalog = begin
-
- let module CompareNum = Make_Compare(D.Num) in
- let module CompareString = Make_Compare(D.String) in
- let module CompareBool = Make_Compare(D.Bool) in
-
+let built_in catalog =
+ let module CompareNum = Make_Compare (D.Num) in
+ let module CompareString = Make_Compare (D.String) in
+ let module CompareBool = Make_Compare (D.Bool) in
(* Helper for list functions : reduce over a list of elements *)
- let reduce name typ res f c = begin
- C.register1 name (t_list typ) res (fun x ->
- List.fold_left f (List.hd x) x) c
- |> C.register1 name (t_list (t_list typ)) res (fun x ->
- List.fold_left (List.fold_left f) (List.hd (List.hd x)) x);
- end in
+ let reduce name typ res f c =
+ C.register1 name (t_list typ) res
+ (fun x -> List.fold_left f (List.hd x) x)
+ c
+ |> C.register1 name
+ (t_list (t_list typ))
+ res
+ (fun x -> List.fold_left (List.fold_left f) (List.hd (List.hd x)) x)
+ in
(* Helper for list functions : fold over a list of elements *)
- let fold name t_in t_out f init c = begin
- C.register1 name (t_list t_in) t_out (fun x ->
- List.fold_left f init x) c
- |> C.register1 name (t_list (t_list t_in)) t_out (fun x ->
- List.fold_left (List.fold_left f) init x)
- end in
+ let fold name t_in t_out f init c =
+ C.register1 name (t_list t_in) t_out (fun x -> List.fold_left f init x) c
+ |> C.register1 name
+ (t_list (t_list t_in))
+ t_out
+ (fun x -> List.fold_left (List.fold_left f) init x)
+ in
-
- let if_: type a. bool -> a -> a -> a = fun a b c -> if a then b else c in
+ let if_ : type a. bool -> a -> a -> a = fun a b c -> if a then b else c in
(* Build a date *)
- C.register3 "date" (t_int, t_int, t_int) f_date (
- fun year month day ->
- D.Date.get_julian_day
- (D.Num.to_int year)
- (D.Num.to_int month)
- (D.Num.to_int day)
- ) catalog
+ C.register3 "date" (t_int, t_int, t_int) f_date
+ (fun year month day ->
+ D.Date.get_julian_day (D.Num.to_int year) (D.Num.to_int month)
+ (D.Num.to_int day))
+ catalog
|> CompareNum.register t_int
-
- |> C.register1 "rand" t_unit f_number D.Num.rnd
-
- |> C.register1 "pi" t_unit f_number (fun () -> D.Num.of_float (4. *. atan 1.))
- |> C.register1 "sin" t_int f_number (fun x -> D.Num.of_float (sin (D.Num.to_float x)))
- |> C.register1 "cos" t_int f_number (fun x -> D.Num.of_float (cos (D.Num.to_float x)))
- |> C.register1 "tan" t_int f_number (fun x -> D.Num.of_float (tan (D.Num.to_float x)))
- |> C.register1 "atan" t_int f_number (fun x -> D.Num.of_float (atan (D.Num.to_float x)))
- |> C.register1 "asin" t_int f_number (fun x -> D.Num.of_float (asin (D.Num.to_float x)))
- |> C.register1 "acos" t_int f_number (fun x -> D.Num.of_float (acos (D.Num.to_float x)))
- |> C.register1 "sinh" t_int f_number (fun x -> D.Num.of_float (sinh (D.Num.to_float x)))
- |> C.register1 "cosh" t_int f_number (fun x -> D.Num.of_float (cosh (D.Num.to_float x)))
- |> C.register1 "tanh" t_int f_number (fun x -> D.Num.of_float (tanh (D.Num.to_float x)))
- |> C.register2 "atan2" (t_int, t_int)f_number (fun x y ->
- D.Num.of_float (atan2 (D.Num.to_float x) (D.Num.to_float y))
- )
-
- |> C.register1 "sqrt" t_int f_number (fun x -> D.Num.of_float (sqrt(D.Num.to_float x)))
- |> C.register1 "exp" t_int f_number (fun x -> D.Num.of_float (exp (D.Num.to_float x)))
- |> C.register1 "ln" t_int f_number (fun x -> D.Num.of_float (log (D.Num.to_float x)))
-
+ |> C.register1 "rand" t_unit f_number D.Num.rnd
+ |> C.register1 "pi" t_unit f_number (fun () -> D.Num.of_float (4. *. atan 1.))
+ |> C.register1 "sin" t_int f_number (fun x ->
+ D.Num.of_float (sin (D.Num.to_float x)))
+ |> C.register1 "cos" t_int f_number (fun x ->
+ D.Num.of_float (cos (D.Num.to_float x)))
+ |> C.register1 "tan" t_int f_number (fun x ->
+ D.Num.of_float (tan (D.Num.to_float x)))
+ |> C.register1 "atan" t_int f_number (fun x ->
+ D.Num.of_float (atan (D.Num.to_float x)))
+ |> C.register1 "asin" t_int f_number (fun x ->
+ D.Num.of_float (asin (D.Num.to_float x)))
+ |> C.register1 "acos" t_int f_number (fun x ->
+ D.Num.of_float (acos (D.Num.to_float x)))
+ |> C.register1 "sinh" t_int f_number (fun x ->
+ D.Num.of_float (sinh (D.Num.to_float x)))
+ |> C.register1 "cosh" t_int f_number (fun x ->
+ D.Num.of_float (cosh (D.Num.to_float x)))
+ |> C.register1 "tanh" t_int f_number (fun x ->
+ D.Num.of_float (tanh (D.Num.to_float x)))
+ |> C.register2 "atan2" (t_int, t_int) f_number (fun x y ->
+ D.Num.of_float (atan2 (D.Num.to_float x) (D.Num.to_float y)))
+ |> C.register1 "sqrt" t_int f_number (fun x ->
+ D.Num.of_float (sqrt (D.Num.to_float x)))
+ |> C.register1 "exp" t_int f_number (fun x ->
+ D.Num.of_float (exp (D.Num.to_float x)))
+ |> C.register1 "ln" t_int f_number (fun x ->
+ D.Num.of_float (log (D.Num.to_float x)))
|> C.register3 "if" (t_bool, t_int, t_int) f_number if_
|> C.register3 "if" (t_bool, t_bool, t_bool) f_bool if_
|> C.register3 "if" (t_bool, t_string, t_string) f_string if_
-
- |> C.register1 "abs" t_int f_number D.Num.abs
- |> C.register1 "int" t_int f_number D.Num.floor
- |> C.register1 "rounddown" t_int f_number D.Num.round_down
- |> C.register1 "round" t_int f_number D.Num.round
-
- |> C.register1 "trim" t_string f_string UTF8.trim
- |> C.register1 "right" t_string f_string (fun x -> UTF8.get x (-1))
- |> C.register2 "right" (t_string, t_int) f_string (
- fun t n ->
- let n' = D.Num.to_int n in
- UTF8.sub t (-(n')) n'
- )
- |> C.register1 "left" t_string f_string (fun x -> UTF8.get x 0)
- |> C.register2 "left" (t_string, t_int) f_string (
- fun t n ->
- let n' = D.Num.to_int n in
- UTF8.sub t 0 n'
- )
- |> C.register1 "len" t_string f_number (fun x -> D.Num.of_int (UTF8.length x))
- |> C.register1 "lenb" t_string f_number (fun x -> D.Num.of_int (String.length (UTF8.to_utf8string x)))
- |> C.register1 "lower" t_string f_string UTF8.lower
- |> C.register1 "unicode" t_string f_number (fun x -> D.Num.of_int (UTF8.code x))
- |> C.register1 "unichar" t_int f_string (fun x -> UTF8.char (D.Num.to_int x))
- |> C.register1 "upper" t_string f_string UTF8.upper
- |> C.register3 "substitute" (t_string, t_string, t_string) f_string UTF8.replace
- |> C.register2 "rept" (t_string, t_int) f_string (fun t n -> UTF8.repeat (D.Num.to_int n) t)
-
+ |> C.register1 "abs" t_int f_number D.Num.abs
+ |> C.register1 "int" t_int f_number D.Num.floor
+ |> C.register1 "rounddown" t_int f_number D.Num.round_down
+ |> C.register1 "round" t_int f_number D.Num.round
+ |> C.register1 "trim" t_string f_string UTF8.trim
+ |> C.register1 "right" t_string f_string (fun x -> UTF8.get x (-1))
+ |> C.register2 "right" (t_string, t_int) f_string (fun t n ->
+ let n' = D.Num.to_int n in
+ UTF8.sub t (-n') n')
+ |> C.register1 "left" t_string f_string (fun x -> UTF8.get x 0)
+ |> C.register2 "left" (t_string, t_int) f_string (fun t n ->
+ let n' = D.Num.to_int n in
+ UTF8.sub t 0 n')
+ |> C.register1 "len" t_string f_number (fun x -> D.Num.of_int (UTF8.length x))
+ |> C.register1 "lenb" t_string f_number (fun x ->
+ D.Num.of_int (String.length (UTF8.to_utf8string x)))
+ |> C.register1 "lower" t_string f_string UTF8.lower
+ |> C.register1 "unicode" t_string f_number (fun x ->
+ D.Num.of_int (UTF8.code x))
+ |> C.register1 "unichar" t_int f_string (fun x -> UTF8.char (D.Num.to_int x))
+ |> C.register1 "upper" t_string f_string UTF8.upper
+ |> C.register3 "substitute"
+ (t_string, t_string, t_string)
+ f_string UTF8.replace
+ |> C.register2 "rept" (t_string, t_int) f_string (fun t n ->
+ UTF8.repeat (D.Num.to_int n) t)
|> CompareBool.register t_bool
- |> C.register1 "true" t_unit f_bool (fun () -> D.Bool.true_)
- |> C.register1 "false" t_unit f_bool (fun () -> D.Bool.false_)
- |> C.register1 "not" t_bool f_bool D.Bool.not
- |> C.register2 "and" (t_bool, t_bool) f_bool D.Bool.and_
- |> C.register2 "or" (t_bool, t_bool) f_bool D.Bool.or_
- |> C.register2 "xor" (t_bool, t_bool) f_bool D.Bool.neq
-
+ |> C.register1 "true" t_unit f_bool (fun () -> D.Bool.true_)
+ |> C.register1 "false" t_unit f_bool (fun () -> D.Bool.false_)
+ |> C.register1 "not" t_bool f_bool D.Bool.not
+ |> C.register2 "and" (t_bool, t_bool) f_bool D.Bool.and_
+ |> C.register2 "or" (t_bool, t_bool) f_bool D.Bool.or_
+ |> C.register2 "xor" (t_bool, t_bool) f_bool D.Bool.neq
|> CompareString.register t_string
-
|> reduce "min" t_int f_num D.Num.min (* Minimum value from a list *)
|> reduce "max" t_int f_num D.Num.max (* Maximum value from a list *)
-
- |> fold "sum" t_int f_number D.Num.add (D.Num.zero)
- |> fold "product" t_int f_number D.Num.mult (D.Num.one)
-
- |> C.register2 "^" (t_int, t_int) f_number D.Num.pow
- |> C.register2 "power" (t_int, t_int) f_number D.Num.pow
-
- |> C.register2 "gcd"(t_int, t_int) f_number D.Num.gcd
- |> C.register2 "lcm"(t_int, t_int) f_number D.Num.lcm
- |> C.register1 "+" t_int f_num (fun x -> x)
- |> C.register1 "-" t_int f_num D.Num.neg (* Unary negation *)
- |> C.register2 "+" (t_int, t_int) f_num D.Num.add
- |> C.register2 "-" (t_int, t_int) f_num D.Num.sub
- |> C.register2 "*" (t_int, t_int) f_number D.Num.mult
- |> C.register2 "/" (t_int, t_int) f_number D.Num.div
-
-end
+ |> fold "sum" t_int f_number D.Num.add D.Num.zero
+ |> fold "product" t_int f_number D.Num.mult D.Num.one
+ |> C.register2 "^" (t_int, t_int) f_number D.Num.pow
+ |> C.register2 "power" (t_int, t_int) f_number D.Num.pow
+ |> C.register2 "gcd" (t_int, t_int) f_number D.Num.gcd
+ |> C.register2 "lcm" (t_int, t_int) f_number D.Num.lcm
+ |> C.register1 "+" t_int f_num (fun x -> x)
+ |> C.register1 "-" t_int f_num D.Num.neg (* Unary negation *)
+ |> C.register2 "+" (t_int, t_int) f_num D.Num.add
+ |> C.register2 "-" (t_int, t_int) f_num D.Num.sub
+ |> C.register2 "*" (t_int, t_int) f_number D.Num.mult
+ |> C.register2 "/" (t_int, t_int) f_number D.Num.div
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-02 02:31:42 +0000