path: root/src/scTypes.ml

(*
This file is part of licht.

licht is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

licht is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with licht.  If not, see <http://www.gnu.org/licenses/>.
*)

(** All the types used in the spreadsheet. *)

let u = UTF8.from_utf8string

exception Error

module DataFormat = struct

  type _ t =
    | Date:   DataType.Num.t t   (* Date *)
    | Number: DataType.Num.t t   (* Number *)
    | String: DataType.String.t t(* String  *)
    | Bool:   DataType.Bool.t t  (* Boolean *)

  type formats = F : 'a t -> formats [@@unboxed]

  let priority: type a. a t -> int = function
    | Date   -> 1
    | Number -> 0
    | String -> 0
    | Bool   -> 0

  let collect_format: DataType.Num.t t -> formats -> DataType.Num.t t = begin
  fun dataFormat -> function
    | F Date -> Date
    | _ -> dataFormat
  end

  let default_value_for: type a. a t -> 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 t -> b t -> (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

  type 'a t =
    | Num  : DataType.Num.t DataFormat.t * DataType.Num.t -> DataType.Num.t t    (** A number *)
    | Str  : DataType.String.t -> DataType.String.t t         (** A string *)
    | Bool : DataType.Bool.t -> DataType.Bool.t t             (** A boolean *)

  let number n = Num (Number, n)
  let string s = Str s
  let date d = Num (Date, d)
  let boolean b = Bool b

  let (=) : type a b. a t -> b t -> 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

  module Eval(T:Sym_type.SYM_TYPE) = struct

    let eval_type : type a. a t -> a T.t = function
    | Str s -> T.str s
    | Bool b -> T.bool b
    | Num (f, n) ->
      match f with
      | DataFormat.Number -> T.num n
      | DataFormat.Date -> T.date n

    let eval t = T.observe (eval_type t)

  end

end

module Refs = struct

  type t =
    | Cell of Cell.t                                      (** A cell *)
    | Range of Cell.t * Cell.t                            (** An area of cells *)

  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 cell c = Cell c
  let range c1 c2 = Range (c1, c2)

  module Eval(R:Sym_ref.SYM_REF) = struct

    let eval_ref = function
    | Cell c -> R.cell c
    | Range(c1, c2) -> R.range c1 c2

    let eval t = R.observe (eval_ref t)

  end

end

module Expr = struct

  type ident = UTF8.t

  type t =
    | Value : 'a Type.t -> t          (** A direct value *)
    | Ref : Refs.t -> t               (** A reference to another cell *)
    | Call0 : ident -> t              (** A call to a 0 arg function *)
    | Call1 : ident * t -> t          (** A call to a 1 arg function *)
    | Call2 : ident * t * t -> t      (** A call to a 2 arg function *)
    | Call3 : ident * t * t * t -> t  (** A call to a 3 arg function *)
    | CallN : ident * t list -> t     (** A call to a function *)
    | Expression : t -> t             (** An expression *)

  let value v = Value v
  let ref r = Ref r
  let call0 ident = Call0 ident
  let call1 ident expr = Call1 (ident, expr)
  let call2 ident expr1 expr2 = Call2(ident, expr1, expr2)
  let call3 ident expr1 expr2 expr3 = Call3(ident, expr1, expr2, expr3)
  let callN ident params = CallN(ident, params)
  let expression e = Expression e

  let rec shift_exp vector = function
    | Value v -> Value v
    | Call0 ident -> Call0 ident
    | Call1 (ident, p1) -> Call1 (ident, shift_exp vector p1)
    | Call2 (ident, p1, p2) -> Call2 (ident, shift_exp vector p1, shift_exp vector p2)
    | Call3 (ident, p1, p2, p3) -> Call3 (ident, shift_exp vector p1, shift_exp vector p2, shift_exp vector p3)
    | CallN (ident, params) -> CallN (ident, List.map (shift_exp vector) params)
    | Ref r -> Ref (Refs.shift vector r)
    | Expression expr -> Expression (shift_exp vector expr)

  module Eval(E:Sym_expr.SYM_EXPR) = struct

    module T = Type.Eval(E.T)
    module R = Refs.Eval(E.R)

    let eval e t = begin

      let rec _eval v k = begin match v with
      | Ref r -> k @@ E.ref (R.eval_ref r) t
      | Value v -> k @@ E.value (T.eval_type v) t
      | Call0 ident -> k @@ E.call0 ident t
      | Call1 (ident, p1) ->
        _eval p1 (fun v1 ->
          k @@ E.call1 ident v1 t)
      | Call2 (ident, p1, p2) ->
        _eval p1 (fun v1 ->
          _eval p2 (fun v2 ->
            k @@ E.call2 ident v1 v2 t))
      | Call3 (ident, p1, p2, p3) ->
        (_eval[@tailcall]) p1 (fun v1 ->
         (_eval[@tailcall]) p2 (fun v2 ->
           (_eval[@tailcall]) p3 (fun v3 ->
            k @@ E.call3 ident v1 v2 v3 t)))
      | CallN (ident, exprs) ->
        let mapped = List.map (fun x -> _eval x (fun x -> x)) exprs in
        k @@ E.callN ident mapped t
      | Expression e ->
        (_eval[@tailcall]) e (fun v1 -> k @@ E.expression v1 t)
      end in

      E.observe (_eval e (fun x -> x))
    end

  end

end

module TypeRepr = Type.Eval(Show_type)

module Result = struct

  (** Result from a computation *)
  type t =
    | Ok : 'a Type.t -> t
    | Error : exn -> t

  let (=) t1 t2 =
    match t1, t2 with
    | Ok v1, Ok 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"
    | Ok v ->
          let buffer = UTF8.Buffer.create 16 in
          TypeRepr.eval v buffer;
          UTF8.Buffer.contents buffer
  end

end

module ReturnType = struct

  type 'a t =
    | Num  : DataType.Num.t DataFormat.t option -> DataType.Num.t t    (** A number *)
    | Str  : DataType.String.t t                         (** A string *)
    | Bool : DataType.Bool.t t                           (** A boolean *)

  let f_num: DataType.Num.t t  = Num None
  let f_date: DataType.Num.t t = Num (Some Date)
  let f_number: DataType.Num.t t = Num (Some Number)
  let f_string: DataType.String.t t = Str
  let f_bool: DataType.Bool.t t = Bool

  let guess_format_result: type a. a t -> (unit -> DataFormat.formats list) -> a DataFormat.t =
    fun return params -> begin match return with
    | Str -> DataFormat.String
    | Bool -> DataFormat.Bool
    | Num (Some x) -> x
    | Num None -> List.fold_left DataFormat.collect_format DataFormat.Number (params ())
  end

end