Commits

Anonymous committed d5674bf

/

Comments (0)

Files changed (1)

src/dbi/dbi_pg.ml

 type comp_getter 'a = Af.af record 'a
 ;
 
+type comp_typer 'a = int -> comp_getter 'a
+;
+
+type c_typeerror_wanted = [ CTW_Null | CTW_Not_null ]
+;
+
+type comp_typer2 'a =
+  { c_notnull : comp_typer 'a
+  ; c_nullable : comp_typer (option 'a)
+  ; c_typeerror : c_typeerror_wanted -> ~got:string -> unit
+  }
+;
+
+type make_comp_typer2 'r =
+(*
+  (P.result -> ~row:int -> ~col:int -> 'r) ->
+*)
+  comp_typer2 'r
+;
+
     module WC
      :
       sig
-value string : int -> comp_getter string
+
+value string : make_comp_typer2 string
 ;
-value string_opt : int -> comp_getter (option string)
-;
+
       end
      =
       struct
 
-value string col = fun record ->
-  let pres = record.rres
-  and row = record.rrow in
-  if pres#getisnull row col
-  then
-    raise (Etype "string (not null)" "NULL")
-  else
-    let row = record.rrow in
-    let pres = record.rres in
-    let v = pres#getvalue row col in
-    v
+(*
+type make_comp_typer2 'a 'r =
+  ~want_ftype:string ->
+  ~get_it:(P.result -> ~row:int -> ~col:int -> 'a) ->
+  typer2 'r
+;
+*)
+
+value common get_it ~want_ftype =
+  let want_ftype_notnull = want_ftype ^ " (not null)" in
+  let typeerror ctw ~got =
+    raise
+      (Etype
+         (match ctw with
+          [ CTW_Null -> want_ftype
+          | CTW_Not_null -> want_ftype_notnull
+          ]
+         )
+         got
+      )
+  in
+    { c_notnull = fun col -> fun record ->
+        let pres = record.rres
+        and row = record.rrow in
+        if pres#getisnull row col
+        then
+          typeerror CTW_Not_null ~got:"NULL"
+        else
+          get_it pres ~row ~col
+    ; c_nullable = fun col -> fun record ->
+        let pres = record.rres
+        and row = record.rrow in
+        if pres#getisnull row col
+        then
+          None
+        else
+          Some (get_it pres ~row ~col)
+    ; c_typeerror = typeerror
+    }
 ;
 
-value string_opt col = fun record ->
-  let row = record.rrow in
-  let pres = record.rres in
-  if pres#getisnull row col
-  then None
-  else Some (
-    let v = pres#getvalue row col in
-    v
-   )
+value string = common
+  ~want_ftype:"string"
+  (fun pres ~row ~col ->
+     pres#getvalue row col
+  )
 ;
 
       end
     ;
 
+
     module WU
      :
       sig
   try record_type#fnumber ident with [Not_found -> raise (Efield ident)]
 ;
 
-value common compiled ~check_ftype ~want_ftype ident = fun record_type ->
-  let index = get_index record_type ident in
-  let ty = record_type#ftype index in
-  if not (check_ftype ty)
-  then
-    raise (Etype want_ftype (P.string_of_ftype ty))
-  else
-    compiled index
+type uncomp_typer2 'a =
+  { u_notnull : ident -> uncomp_getter 'a
+  ; u_nullable : ident -> uncomp_getter (option 'a)
+  }
+;
+
+value common compiled ~check_ftype =
+  let
+    { c_notnull = c_notnull
+    ; c_nullable = c_nullable
+    ; c_typeerror = c_typeerror
+    } =
+        compiled
+  in
+  let check_ty ctw record_type index =
+    let ty = record_type#ftype index in
+    if not (check_ftype ty)
+    then
+      c_typeerror ctw ~got:(P.string_of_ftype ty)
+    else
+      ()
+  in
+  { u_notnull = fun ident -> fun record_type ->
+      let index = get_index record_type ident in
+      ( check_ty CTW_Not_null record_type index
+      ; c_notnull index
+      )
+  ; u_nullable = fun ident -> fun record_type ->
+      let index = get_index record_type ident in
+      ( check_ty CTW_Null record_type index
+      ; c_nullable index
+      )
+  }
 ;
 
 value string_check ftype =
   ]
 ;
 
-value string ident = common WC.string ident
-  ~want_ftype: "string (not null)"
-  ~check_ftype: string_check
+value { u_notnull = string ; u_nullable = string_opt } =
+  common WC.string
+    ~check_ftype: string_check
+(*
+    ~want_ftype: "string (not null)"
+*)
 ;
 
-value string_opt ident = common WC.string_opt ident
-  ~want_ftype: "string (nullable)"
-  ~check_ftype: string_check
-;
 
 type sql_t = [= `Null | `String of string ]
 ;
   else
     match record.rres#ftype col with
     [ P.CHAR | P.TEXT | P.NAME | P.VARCHAR ->
-        `String (WC.string col record)
+        `String (WC.string.c_notnull col record)
     | ty -> raise (Etype "get_t-supported" (P.string_of_ftype ty))
     ]
 ;