SQL_ty =
struct
  open Dbf_misc

  type ty = SQL_db.ty

  type numeric_option = SQL_db.numeric_option

  type ty_kind =
    | SQL_TinyInt | SQL_MediumInt | SQL_Int | SQL_BigInt
    | SQL_Double | SQL_Float | SQL_Decimal
    | SQL_Char | SQL_VarChar
    | SQL_TinyBlob | SQL_Blob | SQL_MediumBlob | SQL_LongBlob
    | SQL_TinyText | SQL_Text | SQL_MediumText | SQL_LongText

  type ty_class =
    | SQL_C_Int | SQL_C_Real  | SQL_C_Char

  exception Invalid_type of string

  let kind_string_assoc =
    [(SQL_TinyInt,    "TINYINT");
     (SQL_MediumInt,  "MEDIUMINT");
     (SQL_Int,        "INT");
     (SQL_BigInt,     "BIGINT");
     (SQL_Double,     "DOUBLE");
     (SQL_Float,      "FLOAT");
     (SQL_Decimal,    "DECIMAL");
     (SQL_Char,       "CHAR");
     (SQL_VarChar,    "VARCHAR");
     (SQL_TinyBlob,   "TINYBLOB");
     (SQL_Blob,       "BLOB");
     (SQL_MediumBlob"MEDIUMBLOB");
     (SQL_LongBlob,   "LONGBLOB");
     (SQL_TinyText,   "TINYTEXT");
     (SQL_Text,       "TEXT");
     (SQL_MediumText"MEDIUMTEXT");
     (SQL_LongText,   "LONGTEXT")]

  let numeric_opt_string_assoc =
    [(SQL_db.NO_None,             "");
     (SQL_db.NO_Unsigned,         "UNSIGNED");
     (SQL_db.NO_UnsignedZeroFill"UNSIGNED ZEROFILL")]

  let kind_of_type = function
    | SQL_db.TinyInt   _ -> SQL_TinyInt
    | SQL_db.MediumInt _ -> SQL_MediumInt
    | SQL_db.Int _       -> SQL_Int
    | SQL_db.BigInt _    -> SQL_BigInt

    | SQL_db.Double _  -> SQL_Double
    | SQL_db.Float _   -> SQL_Float
    | SQL_db.Decimal _ -> SQL_Decimal

    | SQL_db.Char _    -> SQL_Char
    | SQL_db.VarChar _ -> SQL_VarChar

    | SQL_db.TinyBlob   -> SQL_TinyBlob
    | SQL_db.Blob       -> SQL_Blob
    | SQL_db.MediumBlob -> SQL_MediumBlob
    | SQL_db.LongBlob   -> SQL_LongBlob

    | SQL_db.TinyText   -> SQL_TinyText
    | SQL_db.Text       -> SQL_Text
    | SQL_db.MediumText -> SQL_MediumText
    | SQL_db.LongText   -> SQL_LongText

  let string_of_kind =
    fun ty -> List.assoc ty kind_string_assoc

  let kind_of_string = fun s ->
    fst (List.find (fun (_, s') -> s = s') kind_string_assoc)

  let string_of_numeric_option =
    fun opt -> List.assoc opt numeric_opt_string_assoc

  let numeric_option_of_string = fun s ->
    fst (List.find (fun (_, s') -> s = s') numeric_opt_string_assoc)

  let class_of_kind = function
    | SQL_TinyInt | SQL_MediumInt | SQL_Int | SQL_BigInt -> SQL_C_Int
    | SQL_Double | SQL_Float | SQL_Decimal               -> SQL_C_Real
    | _                                                  -> SQL_C_Char

  let kind_uses_display_width = fun kind ->
    match class_of_kind kind with
      | SQL_C_Int | SQL_C_Real -> Dbf_misc.Maybe
      | SQL_C_Char ->
          match kind with
            | SQL_Char | SQL_VarChar -> Dbf_misc.Yes
            | _                      -> Dbf_misc.No

  let kind_uses_precision = fun kind ->
    match class_of_kind kind with
      | SQL_C_Real -> Dbf_misc.Maybe
      | _          -> Dbf_misc.No

  let options_of_kind = fun kind ->
    match class_of_kind kind with
      | SQL_C_Int | SQL_C_Real -> snd (List.split numeric_opt_string_assoc)
      | _                      -> []

  let get_display_size = function
    | SQL_db.TinyInt   (iopt, _)
    | SQL_db.MediumInt (iopt, _)
    | SQL_db.Int       (iopt, _)
    | SQL_db.BigInt    (iopt, _)
        -> iopt

    | SQL_db.Double  (opt, _)
    | SQL_db.Float   (opt, _)
    | SQL_db.Decimal (opt, _)
        -> Dbf_misc.apply_opt fst opt

    | SQL_db.Char i
    | SQL_db.VarChar i
      -> Some i

    | _ -> None

  let get_precision = function
    | SQL_db.Double  (opt, _)
    | SQL_db.Float   (opt, _)
    | SQL_db.Decimal (opt, _)
        -> Dbf_misc.apply_opt snd opt

    | _ -> None

  let get_options_as_string = function
    | SQL_db.Double  (_, opt)
    | SQL_db.Float   (_, opt)
    | SQL_db.Decimal (_, opt)
        -> Some (string_of_numeric_option opt)

    | _ -> None

  let type_of_string = fun ?dispsize ?precision ?(options = "") name ->
    let kind =
      try  kind_of_string name
      with Not_found -> raise (Invalid_type ("Unknown type: " ^ name))
    in
      begin
        match (kind_uses_display_width kind, dispsize) with
          | (NoSome _) -> raise (Invalid_type "Type doesn't support display size option")
          | (YesNone)  -> raise (Invalid_type "Type requires display size option")
          | _ -> ()
      endbegin
        match (kind_uses_precision kind, precision) with
          | (NoSome _) -> raise (Invalid_type "Type doesn't support precision option")
          | (YesNone)  -> raise (Invalid_type "Type requires precision option");
          | _ -> ()
      end;
      let options_list = options_of_kind kind in
        if options <> "" && not (List.mem options options_list) then begin
          let msg = Printf.sprintf "Unknown options %s for type %s" options name in
            raise (Invalid_type msg)
        end;
        let dispsize_and_precision_or_nothing = fun () ->
          match (dispsize, precision) with
            | (NoneNone)       -> None
            | (Some i1, Some i2) -> Some (i1, i2)
            | _ ->
                raise
                  (Invalid_type
                     "Need to give display size AND precision OR nothing at all")
        in
        let int_type = fun f_ty ->
          f_ty dispsize (numeric_option_of_string options)
        and real_type = fun f_ty ->
          let opt1 = dispsize_and_precision_or_nothing ()
          and opt2 = numeric_option_of_string options in
            f_ty opt1 opt2
        in
          match name with
            | "TINYINT"   -> int_type (fun ds opt -> SQL_db.TinyInt   (ds, opt))
            | "MEDIUMINT" -> int_type (fun ds opt -> SQL_db.MediumInt (ds, opt))
            | "INT"       -> int_type (fun ds opt -> SQL_db.Int       (ds, opt))
            | "BIGINT"    -> int_type (fun ds opt -> SQL_db.BigInt    (ds, opt))

            | "DOUBLE"  -> real_type (fun iopt opt -> SQL_db.Double  (iopt, opt))
            | "FLOAT"   -> real_type (fun iopt opt -> SQL_db.Float   (iopt, opt))
            | "DECIMAL" -> real_type (fun iopt opt -> SQL_db.Decimal (iopt, opt))

            | "CHAR"    -> SQL_db.Char    (Dbf_misc.unopt dispsize)
            | "VARCHAR" -> SQL_db.VarChar (Dbf_misc.unopt dispsize)

            | "TINYBLOB"   -> SQL_db.TinyBlob
            | "BLOB"       -> SQL_db.Blob
            | "MEDIUMBLOB" -> SQL_db.MediumBlob
            | "LONGBLOB"   -> SQL_db.LongBlob
            | "TINYTEXT"   -> SQL_db.TinyText
            | "TEXT"       -> SQL_db.Text
            | "MEDIUMTEXT" -> SQL_db.MediumText
            | "LONGTEXT"   -> SQL_db.LongText

            | _ -> raise (Invalid_type name)

  let string_of_type = fun ty -> string_of_kind (kind_of_type ty)

  let string_of_type_options = fun ty ->
    match ty with
      | SQL_db.TinyInt   (_, opt)
      | SQL_db.MediumInt (_, opt)
      | SQL_db.Int       (_, opt)
      | SQL_db.BigInt    (_, opt)
        -> Some (string_of_numeric_option opt)

      | SQL_db.Double  (_, opt)
      | SQL_db.Float   (_, opt)
      | SQL_db.Decimal (_, opt)
        -> Some (string_of_numeric_option opt)

      | _ -> None

  let fullstring_of_type = fun ty ->
    let opt_of_string = fun s ->
      if s = "" then None else Some s
    and intopt_string = fun iopt ->
      Dbf_misc.apply_opt (Printf.sprintf "(%d)") iopt
    and int2opt_string = fun i2opt ->
      Dbf_misc.apply_opt
        (fun (i1, i2) -> Printf.sprintf "(%d, %d)" i1 i2) i2opt
    in
      match ty with
        | SQL_db.TinyInt   (i, opt)
        | SQL_db.MediumInt (i, opt)
        | SQL_db.Int       (i, opt)
        | SQL_db.BigInt    (i, opt)
          -> join_opt
            ([Some (string_of_type ty);
              intopt_string (i);
              opt_of_string (string_of_numeric_option opt)])

        | SQL_db.Double  (i, opt)
        | SQL_db.Float   (i, opt)
        | SQL_db.Decimal (i, opt)
          -> join_opt
            ([Some (string_of_type ty);
              int2opt_string (i);
              opt_of_string (string_of_numeric_option opt)])

        | SQL_db.Char    i
        | SQL_db.VarChar i
          -> join_opt
            ([Some (string_of_type ty);
              Some (Printf.sprintf "(%d)" i)])

        | SQL_db.TinyBlob   -> string_of_type ty
        | SQL_db.Blob       -> string_of_type ty
        | SQL_db.MediumBlob -> string_of_type ty
        | SQL_db.LongBlob   -> string_of_type ty

        | SQL_db.TinyText   -> string_of_type ty
        | SQL_db.Text       -> string_of_type ty
        | SQL_db.MediumText -> string_of_type ty
        | SQL_db.LongText   -> string_of_type ty

end