open Camlp4.PreCast
open Printf


module Case_sensitive_string : sig
  type 'a case_sensitive_string
  type lowercase
  type uppercase
  type anycase

  val lowercase_string : string -> lowercase
  val uppercase_string : string -> uppercase
  val anycase_string : string -> anycase

  val lowercase_to_string : lowercase -> string
  val uppercase_to_string : uppercase -> string
  val anycase_to_string : anycase -> string
end = struct
  type 'a case_sensitive_string = string
  type lowercase = [`Lowercase] case_sensitive_string
  type uppercase = [`Uppercase] case_sensitive_string
  type anycase = [`Lowercase | `Uppercase] case_sensitive_string

  let lowercase_string x : lowercase =
    if String.length x = 0 then x
    else match x.[0] with
        'A'..'Z' -> failwith "lowercase_string"
      | _ -> x

  let uppercase_string x : uppercase =
    if String.length x = 0 then x
    else match x.[0] with
        'A'..'Z' -> x
      | _ -> failwith "uppercase_string"

  let anycase_string x : anycase = x

  let lowercase_to_string (x : lowercase) = x
  let uppercase_to_string (x : uppercase) = x
  let anycase_to_string (x : anycase) = x
end

include Case_sensitive_string

type sel_op = Eq | Neq | Lt | Gt | Le | Ge | Like
type order = Asc of uppercase | Desc of uppercase

type sel_expr =
    Sel_and of sel_expr * sel_expr
  | Sel_or of sel_expr * sel_expr
  | Sel_bin_op of sel_op * uppercase * Ast.expr
  | Sel_bin_op' of sel_op * uppercase * uppercase (* predicate between fields *)

type 'a rename = { old_name : 'a; new_name : 'a }

type col_basic_type =
    Boolean | Bytea | Char of Ast.expr | Date | Double | Int | Real | Serial
    | Smallint | Text | Time of Ast.expr | Timestamp of Ast.expr
    | Varchar of Ast.expr

type column_attributes = Unique | Indexed

type col_type = {
  col_basic_type : col_basic_type;
  col_default : Ast.expr option;
  col_foreign : (lowercase * lowercase) option;
  col_codec : lowercase option;
  col_nullable : bool;
  col_prim_key : bool;
  col_attributes : column_attributes list;
}

type col_decl = { col_name : string; col_type : col_type }

module type CODEGENBASE =
sig
  val type_to_field_name : string -> string

  val expand_delegate :
    Ast.Loc.t -> string list -> Ast.expr -> Ast.class_str_item

  val expand_table_decl :
    Ast.Loc.t -> lowercase -> ?indbname:lowercase -> col_decl list -> Ast.str_item
  val expand_table_class :
    Ast.Loc.t -> lowercase -> ?indbname:lowercase -> col_decl list -> Ast.str_item
  val expand_table_schema_decl :
    Ast.Loc.t -> lowercase -> ?indbname:lowercase -> col_decl list -> Ast.str_item

  val expand_project : Ast.Loc.t -> uppercase list -> Ast.expr

  val expand_select : Ast.Loc.t -> sel_expr -> Ast.expr

  val expand_rename : Ast.Loc.t -> uppercase rename list -> Ast.expr

  val expand_update : Ast.Loc.t -> uppercase list -> Ast.expr

  val expand_delete : Ast.Loc.t -> uppercase -> Ast.expr

  val expand_order : Ast.Loc.t -> order list -> Ast.expr

  val expand_product : Ast.Loc.t -> uppercase list -> uppercase list -> Ast.expr
end

module type CODEGEN =
sig
  include CODEGENBASE

  val expand_table_stream_funcs :
    Ast.Loc.t -> lowercase -> col_decl list -> Ast.str_item

  val expand_materialize : Ast.Loc.t -> uppercase list -> Ast.expr
end

module Codegenbase : CODEGENBASE =
struct
  let type_to_field_name s =
    try
      let i = String.index s '_' in
        try
          String.sub s (i+1) (String.length s - (i+1))
        with Invalid_argument _ -> raise Not_found
    with Not_found ->
      invalid_arg ("Invalid constructor used as field name: '" ^ String.escaped s ^
                   "'. Should be Sometable_some_column")

  let mk_expr_list f _loc l =
    List.fold_right (fun x l -> <:expr< [ $f _loc x$ :: $l$ ] >>) l <:expr< [] >>

  let mk_poly_var_type f _loc l =
    List.fold_left
      (fun t x -> <:ctyp< $f _loc x$ | $t$ >>)
      <:ctyp< >>
      l

  let project_function _loc l =
    let patt = List.fold_left
                 (fun s name -> <:patt< (`$uppercase_to_string name$ _ as x) | $s$>>)
                 <:patt< >>
                 l
    in <:expr< fun [ $patt$ -> x ] >>

  let rename_function _loc l =
    let l = List.map
              (fun t ->
                 <:match_case< `$uid:uppercase_to_string t.new_name$ x ->
                                 `$uid:uppercase_to_string t.old_name$ x >>)
              l
    in <:expr< fun [ $list:l$ ] >>

  let unique_id =
    let i = ref 0 in
      fun () -> incr i; "__pa__relational_" ^ string_of_int !i

  let unique_type_var =
    let i = ref 0 in
      fun () -> incr i; "pa_relational_type_" ^ string_of_int !i


  (* PRODUCT *)

  let product_conv_functions _loc l1 l2 =
    let mk_cons_patt _loc l =
      List.fold_left
        (fun s n -> <:patt< `$uppercase_to_string n$ | $s$>>)
        <:patt< >>
        l in
    let mk_patt _loc l =
      List.fold_left
        (fun s n -> <:patt< (`$uppercase_to_string n$ _ as x) | $s$>>)
        <:patt< >>
        l in
    let ty1 = mk_poly_var_type
                (fun _loc n ->
                   <:ctyp< `$uppercase_to_string n$ of '$unique_type_var()$ >>)
                _loc l1 in
    let consty1 = mk_poly_var_type
                (fun _loc n -> <:ctyp< `$uppercase_to_string n$ >>)
                _loc l1 in
    let ty2 = mk_poly_var_type
                (fun _loc n ->
                   <:ctyp< `$uppercase_to_string n$ of '$unique_type_var()$ >>)
                _loc l2 in
    let consty2 = mk_poly_var_type
                (fun _loc n -> <:ctyp< `$uppercase_to_string n$ >>)
                _loc l2 in
    let patt1 = mk_patt _loc l1 in
    let patt2 = mk_patt _loc l2 in
    let conspatt1 = mk_cons_patt _loc l1 in
    let conspatt2 = mk_cons_patt _loc l2 in
      <:expr<
        (fun rel1 rel2 ->
           let fs1 = Relational.conversion_functions rel1 in
           let fs2 = Relational.conversion_functions rel2 in
           let old_to_sql1 = fs1.Relational.value_to_sql in
           let old_of_sql1 = fs1.Relational.value_of_sql in
           let old_to_sql2 = fs2.Relational.value_to_sql in
           let old_of_sql2 = fs2.Relational.value_of_sql in
           let value_to_sql = fun [
               $patt1$ -> (old_to_sql1 :> [ = $ty1$ ] -> string) x
             | $patt2$ -> (old_to_sql2 :> [ = $ty2$ ] -> string) x
           ] in
           let value_of_sql t isnull s =
             let old1 =
               (old_of_sql1 :> [ = $consty1$ ] -> bool -> string -> '$unique_type_var ()$) in
             let old2 =
               (old_of_sql2 :> [ = $consty2$ ] -> bool -> string -> '$unique_type_var ()$)
             in match t with [
                 ($conspatt1$ as n) ->
                     match old1 n isnull s with [
                         $patt1$ -> x
                       | _ -> failwith "PRODUCT conversion function"
                     ]
                 | ($conspatt2$ as n) ->
                     match old2 n isnull s with [
                         $patt2$ -> x
                       | _ -> failwith "PRODUCT conversion function"
                     ]
               ]
           in { Relational.value_to_sql = value_to_sql;
                Relational.value_of_sql = value_of_sql }) >>

  module UStringMap = Map.Make(struct type t = uppercase let compare = compare end)

  let expand_product _loc l1 l2 =
    let rec make_rel_type
          ?(ty1 = <:ctyp< >>) ?(ty2 = <:ctyp< >>) _loc tymap l = match l with
        [] ->
          let ty = <:ctyp< Relational.relation [> $ty1$] [> $ty2$ ] >> in
            (ty, tymap)
      | name :: tl ->
          let tyvar = unique_type_var () in
          let ty1 = <:ctyp< `$uppercase_to_string name$ of '$tyvar$ | $ty1$>> in
          let ty2 = <:ctyp< `$uppercase_to_string name$ | $ty2$ >> in
            make_rel_type ~ty1 ~ty2 _loc (UStringMap.add name tyvar tymap) tl in

    let make_product_type _loc tymap l1 l2 =
      let l = l1 @ l2 in
      let ty1 = mk_poly_var_type
                  (fun _loc name ->
                     try
                       let typevar = UStringMap.find name tymap in
                         <:ctyp< `$uppercase_to_string name$ of '$typevar$ >>
                     with Not_found ->
                       failwith ("PRODUCT: cannot find typevar for " ^
                                 uppercase_to_string name))
                  _loc l in
      let ty2 = mk_poly_var_type
                  (fun _loc name -> <:ctyp< `$uppercase_to_string name$ >>) _loc l
      in <:ctyp< Relational.relation [= $ty1$] [= $ty2$] >> in

    let ty1, tymap = make_rel_type _loc UStringMap.empty l1 in
    let ty2, tymap = make_rel_type _loc tymap l2 in
    let prod_type = make_product_type _loc tymap l1 l2 in
    let names1 = mk_expr_list
                   (fun _loc n ->
                      <:expr< $str:type_to_field_name (uppercase_to_string n)$ >>)
                   _loc l1 in
    let names2 = mk_expr_list
                   (fun _loc n ->
                      <:expr< $str:type_to_field_name (uppercase_to_string n)$ >>)
                   _loc l2 in
    let f1 = project_function _loc l1 in
    let f2 = project_function _loc l2 in
    let convf = product_conv_functions _loc l1 l2 in
    let id1 = unique_id () in
    let id2 = unique_id () in
      <:expr< (fun ($lid:id1$ : $ty1$) ($lid:id2$ : $ty2$) ->
                 (Relational.product $f1$ $f1$ $f2$ $f2$
                    ($convf$ $lid:id1$ $lid:id2$)
                    $names1$ $names2$ $lid:id1$ $lid:id2$ : $prod_type$)) >>

  let string_of_column_attr = function
      Unique -> "Unique"
    | Indexed -> "Indexed"

  let expr_of_column_attr_list _loc l =
    List.fold_right
      (fun att l -> <:expr< [ Relational.Schema.$uid:string_of_column_attr att$ :: $l$ ] >> )
      l <:expr< [] >>

  let column_type {col_type = ty} = match ty.col_codec with
      Some s -> lowercase_to_string s
    | None ->
        match ty.col_basic_type with
            Boolean -> "bool"
          | Bytea | Text | Char _ | Varchar _ -> "string"
          | Double | Real -> "float"
          | Int | Smallint | Serial -> "int"
          | Date | Time _ | Timestamp _ ->
              failwith "FIXME: Data, Time, Timestamp not implemented"

  (* TABLE:
   *  table schema
   *  relation declaration
   *  table helper classes
   *)

  (* schema declaration, used by functions in Relational *)
  let expand_table_schema_decl _loc tblname ?(indbname = tblname) cols =
    let table = lowercase_to_string indbname in
    let bool_expr b = if b then <:expr< True >> else <:expr< False >> in
    let col_expr _loc c =
      let ty = match c.col_type.col_basic_type with
          Boolean -> <:expr< Relational.Schema.Boolean >>
        | Bytea -> <:expr< Relational.Schema.Bytea >>
        | Date -> <:expr< Relational.Schema.Date >>
        | Double -> <:expr< Relational.Schema.Double >>
        | Int -> <:expr< Relational.Schema.Int >>
        | Real -> <:expr< Relational.Schema.Real >>
        | Serial -> <:expr< Relational.Schema.Serial >>
        | Smallint -> <:expr< Relational.Schema.Smallint >>
        | Text -> <:expr< Relational.Schema.Text >>
        | Char e -> <:expr< Relational.Schema.Char $e$ >>
        | Time e -> <:expr< Relational.Schema.Time $e$ >>
        | Timestamp e -> <:expr< Relational.Schema.Timestamp $e$ >>
        | Varchar e -> <:expr< Relational.Schema.Varchar $e$ >> in
      let col_foreign = match c.col_type.col_foreign with
          None -> <:expr< None >>
        | Some (table, col) ->
            <:expr< Some ($str:lowercase_to_string table$,
                          $str:lowercase_to_string col$) >>
      in <:expr<
            { Relational.Schema.col_name = $str:c.col_name$;
              col_type = $ty$; col_foreign = $col_foreign$;
              col_nullable = $bool_expr c.col_type.col_nullable$;
              col_prim_key = $bool_expr c.col_type.col_prim_key$;
              col_attributes = $expr_of_column_attr_list _loc c.col_type.col_attributes$;
            }
            >> in

    let table_columns = mk_expr_list col_expr _loc cols in
    let primkey = (List.find (fun c -> c.col_type.col_prim_key) cols).col_name in
    let schema = <:expr< { Relational.Schema.table_name = $str:table$;
                           table_primkey =
                             ` $uid:String.capitalize (lowercase_to_string tblname)
                                ^ "_" ^primkey$;
                           table_columns = $table_columns$;
                           table_relation = $lid:table$ } >>
    in <:str_item< value $lid:table ^ "_schema"$ = $schema$ >>

  let sql_conv_func _loc prefix t = match t.col_type.col_codec with
      Some s -> <:expr< $lid:prefix ^ lowercase_to_string s$ >>
    | None ->
        let f = prefix ^ column_type t in
          <:expr< Relational.Typeconv.$lid:f$ >>

  let col_nullable t = t.col_type.col_nullable
  let col_prim_key t = t.col_type.col_prim_key

  (* declaration of the relation *)
  let expand_table_decl _loc tblname ?(indbname = tblname) cols =
    let tblname = lowercase_to_string tblname in
    let upper_tblname = String.capitalize tblname in
    let ty_noncons =
      mk_poly_var_type
        (fun _loc col ->
           let cons = upper_tblname ^ "_" ^ col.col_name in
           let ty = <:ctyp< $lid:column_type col$ >> in
           let ty = match col_nullable col with
               false -> ty
             | true -> <:ctyp< option $ty$ >>
           in <:ctyp< `$cons$ of $ty$ >>)
        _loc cols in
    let ty_cons =
      mk_poly_var_type
        (fun _loc col ->
           let cons = upper_tblname ^ "_" ^ col.col_name in <:ctyp< `$cons$ >>)
        _loc cols in

    let to_sql_match_case col =
      let cons = upper_tblname ^ "_" ^ col.col_name in
      let e = <:expr< $sql_conv_func _loc "encode_" col$ x >> in
      let e = match col_nullable col with
          false -> e
        | true ->
            <:expr< match x with [ Some x -> $e$ | None -> "NULL" ] >>
      in <:match_case< `$cons$ x -> $e$ >> in

    let of_sql_match_case col =
      let cons = upper_tblname ^ "_" ^ col.col_name in
      let e = <:expr< $sql_conv_func _loc "decode_" col$ s >> in
      let e = match col_nullable col with
          false ->
            <:expr<
              if isnull then
                raise (Relational.Unexpected_null ($str:lowercase_to_string indbname$,
                                                  $str:col.col_name$, $str:cons$))
              else
                `$cons$ ($e$)
            >>
        | true ->
            <:expr< `$cons$ (if isnull then None else Some $e$) >>
      in <:match_case< `$cons$ -> $e$ >> in

    let to_sql_match_cases = List.map to_sql_match_case cols in
    let of_sql_match_cases = List.map of_sql_match_case cols in
    let colname_list =
      mk_expr_list
        (fun _loc col -> <:expr< $str:col.col_name$ >>)
        _loc cols

    in <:str_item<
         value $lid:lowercase_to_string indbname$ :
           Relational.relation [ = $ty_noncons$ ] [ = $ty_cons$ ] =
             Relational.table $str:lowercase_to_string indbname$ {
               Relational.value_to_sql = fun [ $list:to_sql_match_cases$ ];
               value_of_sql = fun t isnull s ->
                 match t with [ $list:of_sql_match_cases$ ];
             }
             $colname_list$ >>

  let quote_column s =
    let b = Buffer.create (String.length s + 2) in
      Buffer.add_char b '"';
      Buffer.add_string b s;
      Buffer.add_char b '"';
      Buffer.contents b

  (* helper classes *)
  let expand_table_class _loc tblname ?(indbname = tblname) cols =
    let mk_patts cols =
      List.map
        (fun c ->
           match c.col_type.col_default with
               Some e -> <:patt< ?($lid:c.col_name$ = $e$) >>
             | None ->
                 if col_nullable c || col_prim_key c then
                   <:patt< ? $c.col_name$ >>
                 else <:patt< ~ $c.col_name$ >>)
        cols in

    let tblname = lowercase_to_string tblname in
    let indbname = lowercase_to_string indbname in
    let prim_keys, non_prim_keys = List.partition col_prim_key cols in
    let prim_key = match prim_keys with
        k::[] -> k
      | _ -> failwith (sprintf "Table '%s' must have one primary key." indbname) in

    let ivs =
      List.map
        (fun c ->
           let ty =
             if col_nullable c then
               <:ctyp< option $lid:column_type c$ >>
             else <:ctyp< $lid:column_type c$ >>
           in <:class_str_item<
                  value mutable $lid:c.col_name$ : $ty$ = $lid:c.col_name$; >>)
        non_prim_keys in

    let accessors =
      List.fold_right
        (fun c l ->
             let setter = "set_" ^ c.col_name in
             let e = if col_nullable c then <:expr< Some x >> else <:expr< x >> in
             let str_item = <:class_str_item<
                               method $lid:c.col_name$ = $lid:c.col_name$;
                               method $lid:setter$ x =
                                 (modified := True; $lid:c.col_name$ := $e$;); >>
             in str_item :: l)
        non_prim_keys [] in

    let class_expr =
      List.fold_right
        (fun patt ce -> <:class_expr< fun $patt$ -> $ce$ >>)
        (mk_patts non_prim_keys)
        <:class_expr<
          fun () -> object(self)
                      value mutable modified = True;
                      $Ast.crSem_of_list ivs$;
                      $Ast.crSem_of_list accessors$;
                    end>> in

    let base_class =
      <:str_item< class $lid:tblname ^ "_base"$ = $class_expr$; >> in

    let inherit_line cols =
      let args =
        List.fold_left
          (fun s c ->
             match col_nullable c with
                 true ->  <:class_expr< $s$ ? $c.col_name$ >>
               | false -> <:class_expr< $s$ ~ $c.col_name$ >>)
          <:class_expr< $lid:tblname ^ "_base"$>>
          non_prim_keys in
      let args = <:class_expr< $args$ () >> in
        <:class_str_item< inherit $args$; >> in

    let update_sql_expr =
      let clist = List.map (fun c -> c.col_name) non_prim_keys in
      let txt = Printf.sprintf "UPDATE %s SET %s WHERE %s"
                  (String.escaped (quote_column indbname))
                  (String.escaped
                     (String.concat ","
                        (List.map
                           (fun cname -> quote_column(cname) ^ " = %a") clist)))
                  (String.escaped (quote_column(prim_key.col_name) ^ " = %a"))
      in List.fold_left
           (fun e c ->
              let basef = sql_conv_func _loc "encode_" c in
              let f = match col_nullable c with
                | true ->
                    <:expr< fun () -> Relational.Typeconv.encode_nullable $basef$ >>
                | false -> <:expr< fun () -> $basef$ >>
              in <:expr< $e$ $f$ $lid:c.col_name$ >>)
           <:expr< Printf.sprintf $str:txt$ >>
           (non_prim_keys @ [prim_key]) in

    let class_expr_fold_f c s =
      match col_nullable c with
          true ->  <:class_expr< fun ? $c.col_name$ -> $s$ >>
        | false -> <:class_expr< fun ~ $c.col_name$ -> $s$ >> in

    let existent_row_class_expr =
      List.fold_right class_expr_fold_f cols
        <:class_expr< fun () ->
          object
            $inherit_line cols$;
            value $prim_key.col_name$ : $lid:column_type prim_key$ =
              $lid:prim_key.col_name$;
            method $prim_key.col_name$ = $lid:prim_key.col_name$;
            method save : (string -> unit) -> unit =
              fun f ->
                if modified then
                  let sql = $update_sql_expr$ in f sql
                else ();
            initializer
              modified := False;
          end >> in

    let existent_row_class =
      <:str_item< class $lid:tblname$ = $existent_row_class_expr$; >> in

    let insert_sql_expr =
      let clist =
        List.map (fun c -> String.escaped (quote_column c.col_name)) non_prim_keys in
      let fmt = String.concat ","
                  (Array.to_list (Array.make (List.length clist) "%a")) in
      let txt = Printf.sprintf "INSERT INTO %s(%s) VALUES(%s)"
                  (String.escaped (quote_column indbname))
                  (String.concat "," clist) fmt

      in List.fold_left
           (fun e c ->
              let basef = sql_conv_func _loc "encode_" c in
              let f = match col_nullable c || col_prim_key c with
                | true ->
                    <:expr< fun () -> Relational.Typeconv.encode_nullable $basef$ >>
                | false -> <:expr< fun () -> $basef$ >>
              in <:expr< $e$ $f$ $lid:c.col_name$ >>)
           <:expr< Printf.sprintf $str:txt$ >>
           non_prim_keys in

    let new_row_class_expr =
      List.fold_right class_expr_fold_f non_prim_keys
        <:class_expr< fun () ->
          object
            $inherit_line non_prim_keys$;
            method save : (string -> unit) -> unit =
              fun f -> let sql = $insert_sql_expr$ in f sql;
            initializer
              modified := True;
          end >> in

    let new_row_class =
      <:str_item< class $lid:"new_" ^ tblname$ = $new_row_class_expr$; >>

    in <:str_item< $base_class$; $existent_row_class$; $new_row_class$ >>


  (* UPDATE *)

  let expand_update _loc l =
    let primkey = List.hd l in
    let keys = List.tl l in
    let patts =
      <:patt< (schema : Relational.Schema.table
                 (Relational.relation '$lid:unique_type_var()$ '$lid:unique_type_var()$)
                 [ = ` $uid:uppercase_to_string primkey$] )
      >> ::
        List.map (fun ty -> let c = type_to_field_name (uppercase_to_string ty) in
                    <:patt< ~ $lid:c$ >>) l in
    let fmt =
      String.concat " " [
        "UPDATE \\\"%s\\\" SET";
        String.concat " "
          (List.map
             (fun ty ->
                " \\\"" ^ type_to_field_name (uppercase_to_string ty) ^ "\\\" = %a")
             keys);
        " WHERE \\\"" ^ type_to_field_name (uppercase_to_string primkey) ^ "\\\" = %a"
      ] in
    let fmt_funcs l =
      List.fold_left
        (fun s ty ->
           let f = <:expr< (fun () -> conv) >> in
           let v = <:expr< ` $uid:uppercase_to_string ty$
                     $lid:type_to_field_name (uppercase_to_string ty)$ >>
           in f :: v :: s)
        [] l in

    let printf =
      List.fold_left
        (fun s e -> <:expr< $s$ $e$>>)
        <:expr< Printf.sprintf $str:fmt$ schema.Relational.Schema.table_name >>
        (List.concat [fmt_funcs keys; fmt_funcs [primkey]]) in

    let expr = <:expr<
      let rel = schema.Relational.Schema.table_relation in
      let conv = (Relational.conversion_functions rel).Relational.value_to_sql in
         $printf$
      >>

    in List.fold_right (fun patt s -> <:expr< fun $patt$ -> $s$ >>) patts expr


  (* DELETE *)

  let expand_delete _loc primkey_ty =
    let primkey_ty = uppercase_to_string primkey_ty in
    let primkey = type_to_field_name primkey_ty in
    let patts =
      [ <:patt< (schema : Relational.Schema.table
                 (Relational.relation '$lid:unique_type_var()$ '$lid:unique_type_var()$)
                 [ = ` $uid:primkey_ty$] ) >>;
       <:patt< ~ $lid:primkey$ >> ] in
    let fmt = "DELETE FROM \\\"%s\\\" WHERE \\\"" ^ primkey ^"\\\" = %a" in
    let expr = <:expr<
      let rel = schema.Relational.Schema.table_relation in
      let conv = (Relational.conversion_functions rel).Relational.value_to_sql in
        Printf.sprintf $str:fmt$ schema.Relational.Schema.table_name
          (fun () -> conv) (` $primkey_ty$ $lid:primkey$) >>
    in List.fold_right (fun patt s -> <:expr< fun $patt$ -> $s$ >>) patts expr


  (* PROJECT *)

  let project_conv_functions _loc l =
    let ty1 = mk_poly_var_type
                (fun _loc n ->
                   <:ctyp< `$uppercase_to_string n$ of '$unique_type_var()$ >>)
                _loc l in
    let ty2 = mk_poly_var_type
                (fun _loc n -> <:ctyp< `$uppercase_to_string n$ >>)
                _loc l in
    let patt = List.fold_left
                 (fun s name -> <:patt< (`$uppercase_to_string name$ _ as x) | $s$>>)
                 <:patt< >>
                 l
    in <:expr<
         (fun x ->
            let fs = Relational.conversion_functions x in
            let old_to_sql = fs.Relational.value_to_sql in
            let old_of_sql = fs.Relational.value_of_sql in
            let value_to_sql = (old_to_sql :> [ = $ty1$ ] -> string) in
            let value_of_sql =
              let f = (old_of_sql :> [ = $ty2$ ] -> bool -> string -> 'a) in
                fun x isnull s -> match f x isnull s with [
                    $patt$ -> x
                  | _ -> failwith "PROJECT conversion function"
                ]
            in { Relational.value_to_sql = value_to_sql;
                 Relational.value_of_sql = value_of_sql }) >>

  let expand_project _loc l =
    let f = project_function _loc l in
    let convf = project_conv_functions _loc l in
    let fields =
      mk_expr_list
        (fun _loc n ->
           <:expr< $str:type_to_field_name (uppercase_to_string n)$ >>)
        _loc l in
    let typ1 =
      mk_poly_var_type
        (fun _loc n ->
           <:ctyp< `$uppercase_to_string n$ of '$unique_type_var ()$>>)
        _loc l in
    let typ2 = mk_poly_var_type
                 (fun _loc x -> <:ctyp< `$uppercase_to_string x$ >> ) _loc l in
    let id = unique_id () in
      <:expr< (fun $lid:id$ ->
                 (Relational.project $f$ ($convf$ $lid:id$)
                    $fields$ $lid:id$ :
                    Relational.relation [= $typ1$] [= $typ2$] )) >>


  (* SELECT *)

  let string_of_op = function
      Eq -> "Eq"
    | Neq -> "Neq"
    | Lt -> "Lt"
    | Gt -> "Gt"
    | Le -> "Le"
    | Ge -> "Ge"
    | Like -> "Like"

  let rec expand_select_expr _loc = function
    | Sel_and (e1, e2) ->
        let e1 = expand_select_expr _loc e1 in
        let e2 = expand_select_expr _loc e2 in
          <:expr< Relational.Sel_and [$e1$; $e2$] >>
    | Sel_or (e1, e2) ->
        let e1 = expand_select_expr _loc e1 in
        let e2 = expand_select_expr _loc e2 in
          <:expr< Relational.Sel_or [$e1$; $e2$] >>
    | Sel_bin_op (op, field, e) ->
        let op = string_of_op op in
        let const = uppercase_to_string field in
        let field = type_to_field_name const in
          <:expr< Relational.Sel_binop
                   (Relational.$uid:op$, (`$uid:const$ ($e$)),
                    `$uid:const$, $str:field$) >>
    | Sel_bin_op' (op, field1, field2) ->
        let const1 = uppercase_to_string field1 in
        let const2 = uppercase_to_string field2 in
        let field1 = type_to_field_name const1 in
        let field2 = type_to_field_name const2 in
        let typef =
          <:expr< fun [ (`$uid:const1$ x, `$uid:const2$ y) -> x = y
                      | _ -> True ] >> in
        let op = string_of_op op in
          <:expr< Relational.Sel_binop'
                    (Relational.$uid:op$, `$uid:const1$, `$uid:const2$,
                     $str:field1$, $str:field2$, $typef$) >>

  let expand_select _loc sel =
    let criteria = expand_select_expr _loc sel in
    let ty1 = unique_type_var () in
    let ty2 = unique_type_var () in
    let ty3 = unique_type_var () in
      <:expr< ( Relational.select $criteria$
                  : ((Relational.relation '$ty1$ '$ty2$) as '$ty3$) -> '$ty3$ )>>

  (* RENAME *)

  let rename_conv_functions _loc l =
    let mk_patt l =
      List.fold_left
        (fun s n -> <:patt< (`$uppercase_to_string n$ _ as x) | $s$>>)
        <:patt< >>
        l in
    let srcty1 = mk_poly_var_type
                (fun _loc t ->
                   <:ctyp< `$uppercase_to_string t.old_name$ of '$unique_type_var()$ >>)
                _loc l in
    let srcty2 = mk_poly_var_type
                (fun _loc t -> <:ctyp< `$uppercase_to_string t.old_name$ >>)
                _loc l in
    let dstpatt = mk_patt (List.map (fun t -> t.new_name) l) in
    let srcpatt = mk_patt (List.map (fun t -> t.old_name) l) in
    let rev_renf_matching =
      List.map
        (fun t ->
           <:match_case< `$uid:uppercase_to_string t.old_name$ x ->
                `$uid:uppercase_to_string t.new_name$ x >>)
        l in
    let cons_renf_matching =
      List.map
        (fun t ->
           <:match_case< `$uid:uppercase_to_string t.new_name$ ->
                `$uid:uppercase_to_string t.old_name$ >>)
        l
    in <:expr<
         (fun x ->
            let fs = Relational.conversion_functions x in
            let old_to_sql = fs.Relational.value_to_sql in
            let old_of_sql = fs.Relational.value_of_sql in
            let renf = $rename_function _loc l$ in
            let rev_renf = fun [ $list:rev_renf_matching$ ] in
            let cons_renf = fun [ $list:cons_renf_matching$ ] in
            let value_to_sql = fun [
              $dstpatt$ -> (old_to_sql :> [ = $srcty1$ ] -> string)
                             (renf x) ] in
            let value_of_sql t isnull s =
              let old = (old_of_sql :> [ = $srcty2$ ] -> bool ->
                           string -> '$unique_type_var ()$) in
              let t = cons_renf t in
                match old t isnull s with [
                  $srcpatt$ -> rev_renf x
                  | _ -> failwith "RENAME conversion function"
                ]
            in { Relational.value_to_sql = value_to_sql;
                 Relational.value_of_sql = value_of_sql }) >>

  let expand_rename _loc l =
    let f = rename_function _loc l in
    let l' = mk_expr_list
               (fun _loc t ->
                  let _new = type_to_field_name (uppercase_to_string t.new_name) in
                  let _old = type_to_field_name (uppercase_to_string t.old_name) in
                    <:expr< ($str:_new$, $str:_old$) >>)
               _loc l in
    let id = unique_id () in
    let convf = rename_conv_functions _loc l in
    let expr = <:expr< Relational.rename $f$ ($convf$ $lid:id$) $l'$ >> in
    let ty1 = mk_poly_var_type
                (fun _loc t -> <:ctyp< `$uppercase_to_string t.new_name$ >>)
                _loc l in
    let ty2 = unique_type_var () in
      <:expr< fun $lid:id$ ->
                ( $expr$ $lid:id$ : Relational.relation '$ty2$ [= $ty1$] ) >>


  (* ORDER *)

  let expand_order _loc l =
    let ord = mk_expr_list (fun _loc -> function
                        | Asc s ->
                            let s = uppercase_to_string s in
                            let s2 = type_to_field_name s in
                              <:expr< Relational.Asc (`$uid:s$, $str:s2$) >>
                        | Desc s ->
                            let s = uppercase_to_string s in
                            let s2 = type_to_field_name s in
                              <:expr< Relational.Desc (`$uid:s$, $str:s2$) >>)
                _loc l
    in <:expr< Relational.order $ord$ >>


  (* delegate  *)

  let expand_delegate _loc l e =
    List.fold_right
      (fun meth s -> <:class_str_item< method $lid:meth$ = $e$#$lid:meth$; $s$ >>)
      l
      <:class_str_item< >>
end

module Postgresql_codegen : CODEGEN =
struct
  include Codegenbase

  (* Iteration and stream functions *)

  let expand_table_stream_funcs _loc tblname cols =
    let tblname = lowercase_to_string tblname in
    let upper_tblname = String.capitalize tblname in
    let obj =
      List.fold_left
        (fun e c ->
           let cons = upper_tblname ^ "_" ^ c.col_name in
           let numid = "col_" ^ c.col_name in
           let conv = <:expr< match conv `$cons$ (ret#getisnull i $lid:numid$)
                                      (ret#getvalue i $lid:numid$)
                              with [ ` $cons$ x -> x | _ -> assert False ] >>
           in
             if c.col_type.col_nullable then
               <:expr< $e$ ? $c.col_name$:$conv$ >>
             else
               <:expr< $e$ ~ $c.col_name$:($conv$) >>)
        <:expr< new $lid:tblname$ >>
       cols in
    let expr_with_colnum exp =
      List.fold_right
        (fun c e ->
           let cname = c.col_name in
             <:expr< let $lid:"col_" ^ cname$ = fnum $str:cname$ in $e$ >>)
        cols
        exp in
    let iter_expr = <:expr< for i = 0 to ntuples - 1 do f ($obj$ ()) done >>  in
    let stream_expr =
      <:expr< Stream.from (fun i ->
                             if i >= ntuples then None
                             else Some ($obj$ ())) >>
    in <:str_item<
          value $lid:tblname ^ "_stream"$ ?(klass = new $lid:tblname$) (db : #Postgresql.connection) rel =
            let sql = Relational.to_sql rel in
            let ret = db#exec sql in
            let fnum : string -> int = ret#fnumber in
            let ntuples = ret#ntuples in
            let conv = (Relational.conversion_functions rel).Relational.value_of_sql in
              $expr_with_colnum stream_expr$;

          value $lid:tblname ^ "_iter"$ ?(klass = new $lid:tblname$) f (db : #Postgresql.connection) rel =
            let sql = Relational.to_sql rel in
            let ret = db#exec sql in
            let fnum : string -> int = ret#fnumber in
            let ntuples = ret#ntuples in
            let conv = (Relational.conversion_functions rel).Relational.value_of_sql in
              $expr_with_colnum iter_expr$;
       >>


  (* MATERIALIZE *)

  let expand_materialize _loc l =
    let class_str_items =
      List.fold_right
        (fun ty l ->
           let ty = uppercase_to_string ty in
           let col = type_to_field_name ty in
           let col_num = <:expr< $lid:"col_" ^ col$ >> in
           let c_str_item = <:class_str_item<
               value mutable $lid:col$ =
                 match conv ` $uid:ty$
                         (ret#getisnull i $col_num$)
                         (ret#getvalue i $col_num$) with
                     [ ` $uid:ty$ x -> x | _ -> assert False ];
               method $lid:col$ = $lid:col$;
               method $lid:"set_" ^ col$ x = (modified := True; $lid:col$ := x);
             >>
           in c_str_item :: l)
        l [] in

    let obj_expr = <:expr<
      Array.init ntuples (fun i -> object
                            value mutable modified = False;
                            method modified = modified;
                            $Ast.crSem_of_list class_str_items$;
                            end)
    >> in

    let e =
      List.fold_right
        (fun ty exp ->
           let col = type_to_field_name (uppercase_to_string ty) in
             <:expr< let $lid:"col_" ^ col$ = fnum $str:col$ in $exp$ >>)
        l obj_expr

    in <:expr< (fun (db : #Postgresql.connection) rel ->
        let sql = Relational.to_sql rel in
        let ret = db#exec sql in
        let fnum = ret#fnumber in
        let ntuples = ret#ntuples in
        let conv = (Relational.conversion_functions rel).Relational.value_of_sql in
          $e$
      )>>
end

module Grammar_extension(M : CODEGEN) : sig val id : string end =
struct
  open M
  module Caml = Syntax

  let id = "pa_relational 0.1.0"

  let make_col_type ty =
    { col_basic_type = ty; col_default = None; col_foreign = None;
      col_codec = None; col_nullable = false; col_prim_key = false;
      col_attributes = [];
    }

  EXTEND Caml.Gram
    GLOBAL: Caml.expr Caml.str_item Caml.class_str_item;

    Caml.class_str_item : [
      [ "delegate"; l = LIST1 [ Caml.a_LIDENT ]; "to"; e = Caml.expr ->
          expand_delegate _loc l e
      ]
    ];

    Caml.str_item : LEVEL "top" [
      [ "TABLE"; tblname = Caml.a_LIDENT; indbname = OPT Caml.a_LIDENT;
        decl = table_decl; "END" ->
          let tblname = lowercase_string tblname in
          let indbname = match indbname with
              Some x -> lowercase_string x | None -> tblname in
          let tbl_decl = expand_table_decl _loc ~indbname tblname decl in
          let class_decl = expand_table_class _loc ~indbname tblname decl in
          let stream_funcs = expand_table_stream_funcs _loc tblname decl in
          let schema = expand_table_schema_decl _loc ~indbname tblname decl in
            <:str_item< $tbl_decl$; $schema$; $class_decl$; $stream_funcs$ >>
      ]
    ];

    table_decl :
      [ [ l = LIST1 ["COLUMN"; c = Caml.a_LIDENT; t = col_type ->
                       { col_name = c; col_type = t } ] -> l ] ];

    col_type :
      [ "foreign" NONA
          [ t = SELF; "FOREIGN"; "(";
            table = Caml.a_LIDENT; ","; col = Caml.a_LIDENT; ")" ->
              { t with col_foreign =
                  Some (lowercase_string table, lowercase_string col) } ]
      | "default" NONA
          [ t = SELF; "DEFAULT"; e = Caml.expr -> { t with col_default = Some e }
          | t = SELF; "NULLABLE" -> { t with col_nullable = true }
          | t = SELF; "AUTO"; "PRIMARY"; "KEY" ->
              { t with col_prim_key = true; }
          | t = SELF; "UNIQUE" -> { t with col_attributes = Unique :: t.col_attributes }
          | t = SELF; "INDEXED" -> { t with col_attributes = Indexed :: t.col_attributes }
          ]
      | "custom" NONA
          [ t = SELF; "("; c = Caml.a_LIDENT; ")" ->
              { t with col_codec = Some (lowercase_string c) } ]
      | "basic" NONA
          [ "BOOLEAN"  -> make_col_type Boolean
          | "BYTEA"    -> make_col_type Bytea
          | "DATE"     -> make_col_type Date
          | "DOUBLE"   -> make_col_type Double
          | "INT"      -> make_col_type Int
          | "REAL"     -> make_col_type Real
          | "SERIAL"   -> make_col_type Serial
          | "SMALLINT" -> make_col_type Smallint
          | "TEXT"     -> make_col_type Text
          | "CHAR"; "("; n = Caml.expr; ")" -> make_col_type (Char n)
          | "TIME"; "("; b = Caml.expr; ")" -> make_col_type (Time b)
          | "TIMESTAMP"; "("; b = Caml.expr; ")" -> make_col_type (Timestamp b)
          | "VARCHAR";   "("; n = Caml.expr; ")" -> make_col_type (Varchar   n) ]
      ];

    Caml.expr: LEVEL "top" [
      [ "PROJECT"; "[";
        l = LIST1 [x = Caml.a_UIDENT -> uppercase_string x] SEP ","; "]" ->
          expand_project _loc l

      | "SELECT"; "["; sel = select_expr; "]" ->
          expand_select _loc sel

      | "RENAME"; "["; l = LIST1 [ rename_col ] SEP ","; "]" ->
          expand_rename _loc l

      | "MATERIALIZE";
        "["; l = LIST1 [ x = Caml.a_UIDENT -> uppercase_string x] SEP ","; "]" ->
          expand_materialize _loc l

      | "UPDATE";
        "["; l = LIST1 [ x = Caml.a_UIDENT -> uppercase_string x] SEP ","; "]" ->
          expand_update _loc l

      | "DELETE"; "["; primkey_ty = Caml.a_UIDENT; "]" ->
          expand_delete _loc (uppercase_string primkey_ty)

      | "ORDER"; "["; l = LIST1 [ x = order_by_col -> x ] SEP ","; "]" ->
          expand_order _loc l

      | "LIMIT" -> <:expr< Relational.limit >>

      | "OFFSET" -> <:expr< Relational.offset >>

      | "PRODUCT";
        "["; l1 = LIST1 [ product_col ] SEP ","; "]";
        "["; l2 = LIST1 [ product_col ] SEP ","; "]" ->
          let is_simple =
            List.fold_left
              (fun s x ->
                 s && (match x with `Simple _ -> true | `Renamed _ -> false))
              true in
          let expand_col_pairs =
            List.map (function
                          `Simple x -> { new_name = x; old_name = x}
                        | `Renamed t -> t) in
          let rename_cols =
            List.map (function `Simple n -> n | `Renamed t -> t.new_name) in
          let rename_if_needed l =
            if is_simple l then
              <:expr< fun x -> x >>
            else
              expand_rename _loc (expand_col_pairs l)
          in
            match is_simple l1, is_simple l2 with
              true, true -> expand_product _loc (rename_cols l1) (rename_cols l2)
            | _ ->
                let rename1 = rename_if_needed l1 in
                let rename2 = rename_if_needed l2 in
                  <:expr<
                    fun a b ->
                      $expand_product _loc (rename_cols l1) (rename_cols l2)$
                         ($rename1$ a) ($rename2$ b) >>
      ]
    ];

    product_col :
      [
        [ x = Caml.a_UIDENT -> `Simple (uppercase_string x)
        (* cannot use rename_col here as camlp4 seemingly cannot left-factorize
         * across rules *)
        | oldname = Caml.a_UIDENT; "AS"; newname = Caml.a_UIDENT ->
            `Renamed { new_name = uppercase_string newname;
                       old_name = uppercase_string oldname } ]
      ];

    rename_col :
      [
        [ oldname = Caml.a_UIDENT; "AS"; newname = Caml.a_UIDENT ->
            { new_name = uppercase_string newname;
              old_name = uppercase_string oldname }
        ]
      ];

    order_by_col :
      [ [ x = Caml.a_UIDENT; "ASC" -> Asc (uppercase_string x)
        | x = Caml.a_UIDENT; "DESC" -> Desc (uppercase_string x)
        | x = Caml.a_UIDENT -> Asc (uppercase_string x) ]
      ];

    select_expr:
      [ "top" LEFTA
          [ x = SELF; "AND"; y = SELF -> Sel_and (x, y)
          | x = SELF; "OR"; y = SELF -> Sel_or (x, y) ]
      | "simple"
          [ e = basic_select_expr -> e
          | "("; e = SELF; ")" -> e ]
      ];

    select_operator:
      [
        [ "=" -> Eq
        | "<>" -> Neq
        | ">" -> Gt
        | "<" -> Lt
        | ">=" -> Ge
        | "<=" -> Le
        | "LIKE" -> Like
        ]
    ];

    basic_select_expr: [
      [ x = Caml.a_UIDENT; op = select_operator; y = Caml.a_UIDENT ->
          Sel_bin_op' (op, uppercase_string x, uppercase_string y)

      | x = Caml.a_UIDENT; op = select_operator; y = Caml.expr ->
          Sel_bin_op (op, uppercase_string x, y) ]
    ];
  END;;
end

let module T = Grammar_extension(Postgresql_codegen) in
  ()