(*
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/>.
*)

let u = UTF8.from_utf8string

module T = Tools
module type DATA_SIG = sig

  type 'a t

  type 'a returnType

  val compare_typ: 'a t -> 'b t -> ('a, 'b) T.cmp

  val repr: Format.formatter -> 'a t -> unit

end

module type CATALOG = sig

  type 'a argument
  type 'a returnType

  type t

  (** Create a new catalog builder used for registering all the functions *)
  type catalog_builder

  (** Empty catalog *)
  val empty: catalog_builder

  val register1:
    string ->                     (* The function name *)
    'a argument ->                (* The signature *)
    'b returnType ->              (* The return type *)
    ('a -> 'b) ->                 (* The function to call *)
    catalog_builder -> catalog_builder

  val register2:
    string ->                     (* The function name *)
    ('a argument * 'b argument) ->(* The signature *)
    'c returnType ->              (* The return type *)
    ( 'a -> 'b -> 'c) ->          (* The function to call*)
    catalog_builder -> catalog_builder

  val register3:
    string ->                     (* The function name *)
    ('a argument * 'b argument * 'c argument) -> (* The signature *)
    'd returnType ->              (* The return type *)
    ( 'a -> 'b -> 'c -> 'd) ->    (* The function to call*)
    catalog_builder -> catalog_builder

  (** Compile the catalog *)
  val compile: catalog_builder -> t


  type result =
    | R : 'a returnType * 'a -> result

  val eval1: t -> string -> ('a argument * 'a) -> result

  val eval2: t -> string -> ('a argument * 'a) -> ('b argument * 'b) -> result

  val eval3: t -> string -> ('a argument * 'a) -> ('b argument * 'b) -> ('c argument * 'c) -> result

end


(** We cannot update an existing function. Any [registerX] function will raise
 [RegisteredFunction] if a function with the same signature already exists in
the catalog. *)
exception RegisteredFunction

(** Catalog for all functions *)
module Make(Data:DATA_SIG) = struct

  type 'a argument = 'a Data.t
  type 'a returnType = 'a Data.returnType

  type result = R : 'a returnType * 'a -> result
  type ex_argument = ExArg : 'a argument -> ex_argument

  type _ lift =
    | Z : result lift (* No more parameter in the function *)
    | S : 'a argument * 't1 lift -> ('a -> 't1) lift (* Add an argument to the function *)

  (** Build a reversed list with each argument mapped *)
  let rev_map: type a. (ex_argument -> 'c) -> a lift -> 'c list = begin fun f lift ->
    let rec map': type a. 'c list -> a lift -> 'c list = fun acc -> function
    | Z -> acc
    | S (l, tl) -> map' ((f (ExArg l))::acc) tl in
    map' [] lift
  end

  (** Get the name for argument *)
  let show_args lift = begin
    let formatter = Format.str_formatter in
    let print (ExArg arg) = begin
      Data.repr formatter arg;
      Format.flush_str_formatter ()
    end in
    List.rev @@ rev_map print lift
  end


  module ComparableSignature = struct

    type 'a t = 'a lift

    (* Type for pure equality *)
    type (_, _) eq = Eq : ('a, 'a) eq

    (** Compare two signature *)
    let rec comp: type a1 a2. a1 lift -> a2 lift -> (a1, a2) T.cmp = fun a b ->
      begin match (a, b) with
      | Z  , Z   -> T.Eq
      | S (arg1, s1), S (arg2, s2) -> begin match Data.compare_typ arg1 arg2 with
        | T.Lt -> T.Lt
        | T.Gt -> T.Gt
        | T.Eq -> begin match comp s1 s2 with
          | T.Eq -> T.Eq
          | T.Lt -> T.Lt
          | T.Gt -> T.Gt
          end
        end
      | _  , Z   -> T.Lt
      | Z  , _   -> T.Gt
    end

    let rec repr : type a. Format.formatter -> a t -> unit = begin fun formatter t -> match t with
      | Z -> Format.fprintf formatter "->"
      | S (t1, f) -> Format.fprintf formatter "(%a,%a)" Data.repr t1 repr f
    end
  end


  module Catalog = Map.Make(String)
  module Functions = Splay.Make(ComparableSignature)

  (* This is the map which contains all the registered functions.
     Each name is binded with another map with contains the function for each
     signature.
   *)
  type t = Functions.t String_dict.t
  type catalog_builder = Functions.t Catalog.t

  let empty = Catalog.empty

  (** Generic register function in the catalog.

     Register a function in the catalog. If the function is already defined,
     raise an exception.

   *)
  let register t name signature f = begin

    let name' = String.uppercase_ascii name in
    let map = begin match Catalog.find name' t with
    | exception Not_found ->
        Functions.add signature f Functions.empty
    | x ->
      if Functions.member signature x then
        raise RegisteredFunction
      else
        Functions.add signature f x
    end in
    Catalog.add name' map t
  end

  let register1 name typ1 result f catalog =
    let f' arg1 = R (result, f arg1) in
    register catalog name (S (typ1, Z)) f'

  let register2 name (typ1, typ2) result f catalog =
    let f' arg1 arg2 = R (result, f arg1 arg2) in
    register catalog name (S (typ1, S (typ2, Z))) f'

  let register3 name (typ1, typ2, typ3) result f catalog =
    let f' arg1 arg2 arg3 = R (result, f arg1 arg2 arg3) in
    register catalog name (S (typ1, S (typ2, S (typ3, Z)))) f'

  (** Look in the catalog for a function with the given name and signature *)
  let find_function:
  type a b. t -> string -> a ComparableSignature.t  -> a =
  begin fun t name signature ->
    try String_dict.find_exn t (String.uppercase_ascii name)
    |> Functions.find signature
    with Not_found ->
        (* None found, build an error message *)
        raise (Errors.Undefined (u name, show_args signature))
  end

  let compile t =

    (* Use efficient String_dict.
       The requirement to have a unique key is garantee by the Map structure.
    *)
    String_dict.of_alist_exn (Catalog.bindings t)


  let eval1 catalog name (t1, arg1) = begin
    let f = find_function catalog name (S (t1, Z)) in
    f arg1
  end

  let eval2 catalog name (t1, arg1) (t2, arg2) = begin
    let f = find_function catalog name (S (t1, S (t2, Z))) in
    f arg1 arg2
  end

  let eval3 catalog name (t1, arg1) (t2, arg2) (t3, arg3) = begin
    let f = find_function catalog name (S (t1, S (t2, S (t3, Z)))) in
    f arg1 arg2 arg3
  end

end