Gen migrate add varchar(N), blob(N) default, collates

lib/dialect.ml

@@ -224,7 +224,7 @@ open Sql
 
 let check_unsigned_type pos = function
   | Source_type.Infer Type.UInt64 -> [get_unsigned_types pos]
-  | Source_type.Int (_, Unsigned) -> [get_unsigned_types pos]
+  | Source_type.Int { sign = Unsigned; _ } -> [get_unsigned_types pos]
   | _ -> []
 
 let check_collation_opt (collation : string located option) =
@@ -376,10 +376,11 @@ and analyze_column_def_internal acc cds k = match cds with
       | None -> acc
     in
     let acc = extra
-      |> List.find_map (function
-          | { value = Alter_action_attr.Default { value = expr; pos }; _ } ->
+      |> List.find_map (fun c ->
+          match c.value with
+          | Alter_action_attr.Default { expr = { value = expr; _ }; _ } ->
               let col_kind = Option.map (fun k -> k.value.collated) kind in
-              Some (get_default_expr ~kind:col_kind ~expr pos)
+              Some (get_default_expr ~kind:col_kind ~expr c.pos)
           | _ -> None)
       |> Option.map_default (fun f -> f :: acc) acc
     in
@@ -437,7 +438,7 @@ and analyze_insert_action acc ias k = match ias with
       analyze_assignment_expr acc conflict_aes (fun acc ->
         analyze_insert_action acc rest k))
 
-let analyze_schema_index idx = match idx.value with
+let analyze_schema_index idx = match idx.value.Sql.idx_kind with
   | Regular_idx -> None
   | Fulltext -> Some (get_fulltext_index idx.pos)
   | Spatial -> None
@@ -455,7 +456,7 @@ let rec analyze stmt =
   | Alter (_, actions) ->
       analyze_alter_action acc actions List.rev
   | Rename _ -> []
-  | CreateIndex (_, _, cols) -> List.concat_map check_collated cols
+  | CreateIndex { ci_cols; _ } -> List.concat_map check_collated ci_cols
   | Insert insert_action ->
       analyze_insert_action acc [insert_action] List.rev
   | Delete (_, where_opt) ->

lib/parser_state.ml

@@ -11,3 +11,18 @@ module Stmt_metadata = struct
   let find_all k = Hashtbl.find_all stmt_metadata k
   let reset () = Hashtbl.reset stmt_metadata
 end
+
+let current_lexbuf : Lexing.lexbuf option ref = ref None
+
+let with_lexbuf lexbuf f =
+  let saved = !current_lexbuf in
+  current_lexbuf := Some lexbuf;
+  Fun.protect f ~finally:(fun () -> current_lexbuf := saved)
+
+let extract_source (start_, end_) =
+  Stdlib.Option.bind !current_lexbuf (fun lexbuf ->
+    let len = end_ - start_ in
+    if len > 0 && start_ >= 0 && end_ <= lexbuf.Lexing.lex_buffer_len then
+      Some (Bytes.sub_string lexbuf.lex_buffer start_ len)
+    else
+      None)

lib/parser_utils.ml

@@ -13,6 +13,7 @@ exception Error of exn * (int * int * string * string)
 module Make(T : Parser_type) =
 struct
   let parse_buf_exn lexbuf =
+    Parser_state.with_lexbuf lexbuf @@ fun () ->
     try
       T.input T.rule lexbuf
     with exn ->

lib/sql.ml

@@ -530,10 +530,23 @@ type float_precision = Single | Double
   [@@deriving show {with_path=false}, eq]
 
 module Source_type = struct
+  type text_flavor =
+    | PlainText of lob_size option   (* TEXT/TINYTEXT/MEDIUMTEXT/LONGTEXT *)
+    | Char of int option
+    | Varchar of int option
+    | Varchar2 of int option
+    [@@deriving show, eq]
+
+  type blob_flavor =
+    | PlainBlob of lob_size option   (* BLOB/TINYBLOB/MEDIUMBLOB/LONGBLOB *)
+    | Varbinary of int option
+    [@@deriving show, eq]
+
   type kind = Infer of Type.kind
-    | Int of int_size option * signedness
+    | Int of { size : int_size option; sign : signedness; display_width : int option }
     | Float of float_precision
-    | Blob of lob_size option | Text of lob_size option
+    | Blob of blob_flavor
+    | Text of text_flavor
     [@@deriving show, eq]
 
   type t = { t : kind; nullability : Type.nullability; } [@@deriving eq, show{with_path=false}, make]
@@ -546,7 +559,7 @@ module Source_type = struct
   let to_infer_type { t; nullability; } =
     let t = match t with
       | Infer ty -> ty
-      | Int (Some Big, Unsigned) -> Type.UInt64
+      | Int { size = Some Big; sign = Unsigned; _ } -> Type.UInt64
       | Int _ -> Type.Int
       | Float _ -> Type.Float
       | Blob _ -> Type.Blob
@@ -733,7 +746,7 @@ type insert_action =
   on_conflict_clause : conflict_clause located option;
 } [@@deriving show {with_path=false}]
 
-type table_constraints = [ `Ignore | `Primary of string list | `Unique of string list ] [@@deriving show {with_path=false}]
+type table_constraints = [ `Ignore | `Primary of string list | `Unique of string option * string list ] [@@deriving show {with_path=false}]
 
 type index_kind  = 
   | Regular_idx
@@ -743,7 +756,10 @@ type index_kind  =
 
 module Alter_action_attr = struct
 
-  type constraint_ = Syntax_constraint of Constraint.t | Default of expr located
+  type default = { expr : expr located; sql : string option }
+    [@@deriving show {with_path=false}]
+
+  type constraint_ = Syntax_constraint of Constraint.t | Default of default
     [@@deriving show {with_path=false}]
 
   type t = {  
@@ -758,9 +774,16 @@ module Alter_action_attr = struct
     | Syntax_constraint c -> c
     | Default _ -> WithDefault
 
+  let default_sql (col : t) =
+    List.find_map (fun (c : constraint_ located) ->
+      match c.value with
+      | Default { sql; _ } -> sql
+      | Syntax_constraint _ -> None
+    ) col.extra
+
   let kind_to_type_kind = function
     | Source_type.Infer k -> k
-    | Source_type.Int (Some Big, Unsigned) -> Type.UInt64
+    | Source_type.Int { size = Some Big; sign = Unsigned; _ } -> Type.UInt64
     | Source_type.Int _ -> Type.Int
     | Source_type.Float _ -> Type.Float
     | Source_type.Blob _ -> Type.Blob
@@ -777,8 +800,10 @@ module Alter_action_attr = struct
   let from_attr (attr: attr): t =
     let extra = attr.extra |> Constraints.elements |> List.map (fun c -> 
       let c = match c with
-      | Constraint.WithDefault -> Default (make_located ~pos:(0,0) ~value:(Value 
-        (make_collated ~collated:(Type.depends Any) ()))) 
+      | Constraint.WithDefault -> Default {
+          expr = make_located ~pos:(0,0) ~value:(Value (make_collated ~collated:(Type.depends Any) ()));
+          sql = None;
+        }
       | x -> Syntax_constraint x
       in
       make_located ~pos:(0,0) ~value:c
@@ -788,10 +813,36 @@ module Alter_action_attr = struct
     { name = attr.name; kind; extra; meta }
 end
 
+type index_op_kind =
+  | Plain_idx
+  | Unique_idx
+  | Fulltext_idx
+  | Spatial_idx
+  [@@deriving show {with_path=false}, eq]
+
+type table_inline_index = {
+  idx_kind : index_kind;
+  idx_name : string option;
+  idx_cols : string list;
+  idx_unique : bool;
+}
+[@@deriving show {with_path=false}]
+
+type add_index = { add_idx_name : string option; add_idx_kind : index_op_kind; add_idx_cols : string list }
+  [@@deriving show {with_path=false}]
+
+type create_index_def = {
+  ci_name : string;
+  ci_table : table_name;
+  ci_cols : string collated list;
+  ci_kind : index_op_kind;
+}
+[@@deriving show {with_path=false}]
+
 type create_target_schema = { 
   schema: Alter_action_attr.t list; 
   constraints: table_constraints list; 
-  indexes: index_kind located list; 
+  indexes: table_inline_index located list; 
 }
 [@@deriving show]
 
@@ -814,7 +865,7 @@ type alter_action = [
     | `RenameIndex of string * string
     | `Drop of string
     | `Change of string * Alter_action_attr.t * alter_pos
-    | `AddIndex of string option * string list
+    | `AddIndex of add_index
     | `DropIndex of string
     | `AddPrimaryKey of string list
     | `DropPrimaryKey
@@ -830,7 +881,7 @@ type stmt =
   | Drop of table_name
   | Alter of table_name * alter_action list
   | Rename of (table_name * table_name) list
-  | CreateIndex of string * table_name * string collated list (* index name, table name, columns *)
+  | CreateIndex of create_index_def
   | Insert of insert_action
   | Delete of table_name * expr option
   | DeleteMulti of table_name list * nested * expr option

lib/sql_lexer.mll

@@ -224,16 +224,19 @@ let keywords =
   all T_BOOLEAN ["bool";"boolean"];
   all T_FLOAT ["float";"real";"float4";"float8";"int1";"int2";"int3";"int4";"int8"];
   all T_DOUBLE ["double"];
-  all (T_BLOB None) ["blob";"varbinary"];
-  all (T_BLOB (Some Tiny)) ["tinyblob"];
-  all (T_BLOB (Some Medium)) ["mediumblob"];
-  all (T_BLOB (Some Long)) ["longblob"];
-  all (T_TEXT None) ["text";"char";"varchar"];
-  all (T_TEXT (Some Tiny)) ["tinytext"];
-  all (T_TEXT (Some Medium)) ["mediumtext"];
-  all (T_TEXT (Some Long)) ["longtext"];
+  all T_BLOB ["blob"];
+  all T_TINYBLOB ["tinyblob"];
+  all T_MEDIUMBLOB ["mediumblob"];
+  all T_LONGBLOB ["longblob"];
+  all T_VARBINARY ["varbinary"];
+  all T_TEXT ["text"];
+  all T_TINYTEXT ["tinytext"];
+  all T_MEDIUMTEXT ["mediumtext"];
+  all T_LONGTEXT ["longtext"];
+  all T_CHAR ["char"];
+  all T_VARCHAR ["varchar"];
+  all T_VARCHAR2 ["varchar2"]; (* oracle *)
   all T_JSON ["json"];
-  all (T_TEXT None) ["varchar2"]; (* oracle *)
   all T_DATETIME ["datetime"];
   all T_UUID ["uuid"]; (* http://www.postgresql.org/docs/9.4/static/datatype-uuid.html *)
   !k