Implement safe enums: literals + poly variants gen

impl/ocaml/mariadb/sqlgg_mariadb.ml

@@ -24,6 +24,14 @@ module type Value = sig
   val to_literal : t -> string
 end
 
+module type Enum = sig 
+  type t
+
+  val inj: string -> t
+
+  val proj: t -> string
+end
+
 module type Types = sig
   type field
   type value
@@ -36,6 +44,7 @@ module type Types = sig
   module Datetime : Value
   module Decimal : Value
   module Any : Value
+  module Make_enum : functor (E : Enum) -> Value with type t = E.t
 end
 
 module Default_types(M : Mariadb.Nonblocking.S) : Types with
@@ -183,6 +192,20 @@ struct
     let to_value x = x
     let to_literal _ = failwith "to_literal Any"
   end)
+
+  module Make_enum (E: Enum) = Make(struct
+
+    include E
+
+    let of_field field = 
+      match M.Field.value field with
+      | `String x -> inj x
+      | value -> convfail "enum" field value
+
+    let to_value v = `String (proj v)
+
+    let to_literal = proj
+  end)
 end
 
 module Make
@@ -258,6 +281,19 @@ let set_param_Float = set_param_ty Float.to_value
 let set_param_Decimal = set_param_ty Decimal.to_value
 let set_param_Datetime = set_param_ty Datetime.to_value
 
+module Make_enum (E: Enum) = struct 
+
+  module E = Make_enum(E)
+
+  type t = E.t
+
+  let get_column, get_column_nullable = get_column_ty "Enum" E.of_field
+
+  let set_param = set_param_ty E.to_value
+
+  let to_literal = E.to_literal
+end
+
 let no_params stmt =
   let open IO in
   M.Stmt.execute stmt [||] >>=

impl/ocaml/mysql/sqlgg_mysql.ml

@@ -126,6 +126,15 @@ type result = P.stmt_result
 type execute_response = { affected_rows: int64; insert_id: int64 }
 
 module Types = T
+
+module type Enum = sig 
+  type t
+
+  val inj: string -> t
+
+  val proj: t -> string
+end
+
 open Types
 
 (* compatibility *)
@@ -178,6 +187,17 @@ let set_param_Float = set_param_ty Float.to_string
 let set_param_Decimal = set_param_ty Decimal.to_string
 let set_param_Datetime = set_param_ty Datetime.to_string
 
+module Make_enum (E: Enum) = struct 
+
+  include E
+
+  let get_column, get_column_nullable = get_column_ty "Enum" E.inj
+
+  let set_param = set_param_ty E.proj
+
+  let to_literal = E.proj
+end
+
 let no_params stmt = P.execute stmt [||]
 
 let try_finally final f x =

impl/ocaml/sqlgg_traits.ml

@@ -20,6 +20,14 @@ module type Value = sig
   val to_literal : t -> string
 end
 
+module type Enum = sig 
+  type t
+
+  val inj: string -> t
+
+  val proj: t -> string
+end
+
 module type M = sig
 
   type statement
@@ -80,6 +88,14 @@ module type M = sig
   val set_param_Decimal : params -> Decimal.t -> unit
   val set_param_Datetime : params -> Datetime.t -> unit
 
+  module Make_enum: functor (E : Enum) -> sig
+    (* The type itself is not exposed to provide a user a polymorphic type without aliases. *)
+    val get_column : row -> int -> E.t
+    val get_column_nullable : row -> int -> E.t option
+    val set_param : params -> E.t -> unit
+    val to_literal : E.t -> string
+  end
+
   val no_params : statement -> result
 
   (**

impl/ocaml/sqlite3/sqlgg_sqlite3.ml

@@ -67,6 +67,14 @@ module Types = struct
   module Any = Text
 end
 
+module type Enum = sig 
+  type t
+
+  val inj: string -> t
+
+  val proj: t -> string
+end
+
 type statement = S.stmt * string
 type 'a connection = S.db
 type params = statement * int * int ref
@@ -110,6 +118,17 @@ let get_column_Float, get_column_Float_nullable = get_column_ty Conv.float
 let get_column_Decimal, get_column_Decimal_nullable = get_column_ty Conv.decimal
 let get_column_Datetime, get_column_Datetime_nullable = get_column_ty Conv.float
 
+module Make_enum (E: Enum) = struct 
+
+  include E
+
+  let get_column, get_column_nullable = failwith "sqlite does not support enums"
+
+  let set_param = failwith "sqlite does not support enums"
+
+  let to_literal = failwith "sqlite does not support enums"
+end
+
 let test_ok sql rc =
   if rc <> S.Rc.OK then
     raise (Oops (sprintf "test_ok %s for %s" (S.Rc.to_string rc) sql))

lib/sql.ml

@@ -6,6 +6,22 @@ open Prelude
 
 module Type =
 struct
+
+  module Enum_kind = struct
+
+    module Ctors =  struct 
+      include Set.Make(String)
+
+      let pp fmt s = 
+        Format.fprintf fmt "{%s}" 
+          (String.concat "; " (elements s))  
+    end
+
+    type t = Ctors.t [@@deriving eq, show{with_path=false}]
+
+    let make ctors =  Ctors.of_list ctors
+  end
+
   type kind =
     | Unit of [`Interval]
     | Int
@@ -15,10 +31,17 @@ struct
     | Bool
     | Datetime
     | Decimal
+    | Union of { ctors: Enum_kind.t; is_closed: bool }
+    | StringLiteral of string
     | Any (* FIXME - Top and Bottom ? *)
     [@@deriving eq, show{with_path=false}]
     (* TODO NULL is currently typed as Any? which actually is a misnormer *)
 
+    let show_kind = function 
+      | Union { ctors; _ } -> sprintf "Union (%s)" (String.concat "| " (Enum_kind.Ctors.elements ctors))
+      | StringLiteral l -> sprintf "StringLiteral (%s)" l
+      | k -> show_kind k
+
   type nullability =
   | Nullable (** can be NULL *)
   | Strict (** cannot be NULL *)
@@ -34,6 +57,8 @@ struct
   let make_nullable { t; nullability=_ } = nullable t
 
   let make_strict { t; nullability=_ } = strict t
+
+  let make_enum_kind ctors = Union { ctors = (Enum_kind.make ctors); is_closed = true }
 
   let is_strict { nullability; _ } = nullability = Strict
 
@@ -50,19 +75,34 @@ struct
   let is_unit = function { t = Unit _; _ } -> true | _ -> false
 
   (** @return (subtype, supertype) *)
-  let order_kind x y =
-    if equal_kind x y then
-      `Equal
-    else
-      match x,y with
-      | Any, t | t, Any -> `Order (t,t)
-      | Int, Float | Float, Int -> `Order (Int,Float)
-      (* arbitrary decision : allow int<->decimal but require explicit cast for floats *)
-      | Decimal, Int | Int, Decimal -> `Order (Int,Decimal)
-      | Text, Blob | Blob, Text -> `Order (Text,Blob)
-      | Int, Datetime | Datetime, Int -> `Order (Int,Datetime)
-      | Text, Datetime | Datetime, Text -> `Order (Datetime,Text)
-      | _ -> `No
+  let order_kind x y =  
+    match x, y with
+    | x, y when equal_kind x y -> `Equal
+    | StringLiteral a, StringLiteral b -> 
+      `StringLiteralUnion (Union { ctors = (Enum_kind.make [a; b]); is_closed = false })
+
+    | StringLiteral a, Union { ctors = b; is_closed  } | Union { ctors = b; is_closed  }, StringLiteral a when Enum_kind.Ctors.mem a b 
+      -> `Order (StringLiteral a, Union { ctors = (Enum_kind.Ctors.add a b); is_closed })
+
+    | StringLiteral a, Union { ctors = b; is_closed = false  }  | Union { ctors = b; is_closed = false  }, StringLiteral a -> 
+      `StringLiteralUnion (Union { ctors = (Enum_kind.Ctors.add a b); is_closed = false; })
+
+    | StringLiteral _  as x , Text -> `Order (x, Text)
+    | Text, (StringLiteral _ as x) -> `Order (x, Text)
+
+    | Text, (Union _ as x) -> `Order (x, Text)
+    | Union { ctors = a; _ } as x1, (Union { ctors = b ;_ } as x2)  when Enum_kind.Ctors.subset b a -> `Order (x2, x1)
+
+    | StringLiteral x, Datetime | Datetime, StringLiteral x -> `Order (Datetime, StringLiteral x)
+    | StringLiteral x, Blob | Blob, StringLiteral x -> `Order (Blob, StringLiteral x)
+    | Any, t | t, Any -> `Order (t, t)
+    | Int, Float | Float, Int -> `Order (Int, Float)
+    | Decimal, Int | Int, Decimal -> `Order (Int, Decimal)
+    | Text, Blob | Blob, Text -> `Order (Text, Blob)
+    | Int, Datetime | Datetime, Int -> `Order (Int, Datetime)
+    | Text, Datetime | Datetime, Text -> `Order (Datetime, Text)
+    | _ -> `No
+
 
   let order_nullability x y =
     match x,y with
@@ -89,19 +129,30 @@ struct
   let common_type_ order x y =
     match order_nullability x.nullability y.nullability, order_kind x.t y.t with
     | _, `No -> None
-    | `Equal nullability, `Order pair -> Some {t = order pair; nullability}
+    | `Equal nullability, `Order pair -> `CommonType pair |> order |> Option.map (fun t -> { t = t; nullability })
     | `Equal nullability, `Equal -> Some { x with nullability }
     | (`Nullable_Strict|`Strict_Nullable), `Equal -> Some (nullable x.t) (* FIXME need nullability order? *)
-    | (`Nullable_Strict|`Strict_Nullable), `Order pair -> Some (nullable @@ order pair)
+    | (`Nullable_Strict|`Strict_Nullable), `Order pair -> `CommonType pair |> order |> Option.map nullable
+    | `Equal nullability, `StringLiteralUnion t -> `StringLiteralUnion t |> order |> Option.map (fun t -> { t = t; nullability })
+    | (`Nullable_Strict | `Strict_Nullable), `StringLiteralUnion t -> `StringLiteralUnion t |> order |> Option.map nullable
 
   let common_type_l_ order = function
   | [] -> None
   | t::ts -> List.fold_left (fun acc t -> match acc with None -> None | Some prev -> common_type_ order prev t) (Some t) ts
 
-  let subtype = common_type_ fst
-  let supertype = common_type_ snd
-  let common_subtype = common_type_l_ fst
-  let common_supertype = common_type_l_ snd
+  let get_subtype = function 
+  | `CommonType t -> Some (fst t)
+  | `StringLiteralUnion t -> Some t
+
+  let get_supertype = function 
+  | `CommonType t -> Some (snd t)
+  | `StringLiteralUnion t -> Some t
+
+  let subtype = common_type_ get_subtype
+  let supertype = common_type_ get_supertype
+  let common_subtype = common_type_l_ get_subtype
+
+  let common_supertype = common_type_l_ get_supertype
 
   let common_type = subtype
 
@@ -435,7 +486,7 @@ and expr =
    (* pos - full syntax pos from {, to }?, pos is only sql, that inside {}?
       to use it during the substitution and to not depend on the magic numbers there.
    *) 
-  | OptionBoolChoices of { choice: expr; pos: (pos * pos) } 
+  | OptionBoolChoices of { choice: expr; pos: (pos * pos) }
 and column =
   | All
   | AllOf of table_name

lib/sql_parser.mly

@@ -440,8 +440,7 @@ expr:
         InTupleList(names, p)
       }
     | LPAREN select=select_stmt RPAREN { SelectExpr (select, `AsValue) }
-    | p=param { Param (new_param p (depends Any)) }
-    | p=param DOUBLECOLON t=manual_type { Param (new_param { p with pos=($startofs, $endofs) } t) }
+    | p=param t=preceded(DOUBLECOLON, manual_type)? { Param (new_param { p with pos=($startofs, $endofs) } (Option.default (depends Any) t))  }
     | LCURLY e=expr RCURLY QSTN { OptionBoolChoices ({ choice=e; pos=(($startofs, $endofs), ($startofs + 1, $endofs - 2))}) }
     | p=param parser_state_ident LCURLY l=choices c2=RCURLY { let { label; pos=(p1,_p2) } = p in Choices ({ label; pos = (p1,c2+1)},l) }
     | SUBSTRING LPAREN s=expr FROM p=expr FOR n=expr RPAREN
@@ -481,6 +480,7 @@ values_stmt1:
 
 values_stmt: 
   | kind=values_stmt1 row_order=loption(order) row_limit=limit_t? {{ row_constructor_list = kind; row_order; row_limit;}}
+
 
 (* https://dev.mysql.com/doc/refman/8.0/en/window-functions-usage.html *)
 window_function:
@@ -513,7 +513,7 @@ choices: separated_nonempty_list(pair(parser_state_ident,NUM_BIT_OR),choice) { $
 datetime_value: | DATETIME_FUNC | DATETIME_FUNC LPAREN INTEGER? RPAREN { Value (strict Datetime) }
 
 strict_value:
-    | TEXT collate? { Text }
+    | TEXT { StringLiteral $1 }
     | BLOB collate? { Blob }
     | INTEGER { Int }
     | FLOAT { Float }
@@ -555,7 +555,7 @@ sql_type_flavor: T_INTEGER UNSIGNED? ZEROFILL? { Int }
                | T_DECIMAL { Decimal }
                | binary { Blob }
                | NATIONAL? text VARYING? charset? collate? { Text }
-               | ENUM sequence(TEXT) charset? collate? { Text }
+               | ENUM ctors=sequence(TEXT) charset? collate? { make_enum_kind ctors }
                | T_FLOAT PRECISION? { Float }
                | T_BOOLEAN { Bool }
                | T_DATETIME | YEAR | DATE | TIME | TIMESTAMP { Datetime }

lib/syntax.ml

@@ -31,6 +31,8 @@ module Tables_with_derived = struct
   let get_from ~env name = get_from  (env.ctes @ env.tables) name
 end
 
+type enum_ctor_value_data = { ctor_name: string; pos: pos; }  [@@deriving show]
+
 (* expr with all name references resolved to values or "functions" *)
 type res_expr =
   | ResValue of Type.t (** literal value *)
@@ -221,7 +223,7 @@ let rec bool_choice_id = function
   | SelectExpr _
   | OptionBoolChoices _
   | Choices _
-  | Value _ -> None 
+  | Value _ -> None
   | Inparam p
   | Param p -> Some p.id
   | Fun (_, exprs) -> List.find_map bool_choice_id exprs

src/cli.ml

@@ -103,6 +103,7 @@ let main () =
     "-static-header", Arg.Unit (fun () -> Sqlgg_config.gen_header := Some `Static), "only output short static header without version/timestamp";
     "-show-tables", Arg.Unit Tables.print_all, " Show all current tables";
     "-show-table", Arg.String Tables.print1, "<name> Show specified table";
+    "-enum-poly-variant", Arg.Unit (fun () -> Sqlgg_config.enum_as_poly_variant := true), " Represent enums as variants in generated code";
     "-", Arg.Unit (fun () -> work "-"), " Read sql from stdin";
     "-test", Arg.Unit Test.run, " Run unit tests";
   ]

src/gen.ml

@@ -181,6 +181,7 @@ let substitute_vars s vars subst_param =
   in
   squash [] acc
 
+
 let subst_named index p = "@" ^ (show_param_name p index)
 let subst_oracle index p = ":" ^ (show_param_name p index)
 let subst_postgresql index _ = "$" ^ string_of_int (index + 1)