1. Dmitry Grebeniuk
  2. amall

Commits

Dmitry Grebeniuk  committed 1388946

/

  • Participants
  • Parent commits b5859ac
  • Branches default

Comments (0)

Files changed (6)

File _tags

View file
 <src/dbi/*.ml{,i}> : camlp4r
 <tests/*.ml> : camlp4r
 <src/am_Ops.*> | <src/filename_new.*> | <src/urilex.ml> : -camlp4r, camlp4o
+<src/dbi/decimal.*> : pkg_num
 

File src/am_Common.ml

View file
 value failwith fmt = Printf.ksprintf failwith fmt
 ;
 
+value invalid_arg fmt = Printf.ksprintf invalid_arg fmt
+;
+
 exception Not_implemented of string
 ;
 

File src/amall_http.ml

View file
 value string_of_header (k, v) =
   let ch c =
     if String.contains k c
-    then invalid_arg & sprintf
+    then invalid_arg
       "http response header: header name should not contain char %C"
       c
     else
 
 
 value string_of_response_headers rs =
-  let err msg = invalid_arg ("http response: " ^ msg) in
+  let err msg = invalid_arg "http response: %s" msg in
   let code = rs.rs_status_code in
   if code < 100 || code >= 1000
   then err & sprintf "status code must be 3-digit (now: %i)" code

File src/dbi/dbi_common.ml

View file
 external identity : 'a -> 'a = "%identity"
 ;
 
-external apply : ('a -> 'b) -> 'a -> 'b = "%apply"
-;
-
 
 module Af
  =
     type af 'x 'a = 'x -> 'a;
     value pure = fun _ -> identity;
     value ( <*> ) fab fa = fun x -> (fab x) (fa x);
-    value run = apply;
+    value run af x = af x;
   end
 ;
 
           fun y ->
             (fab y) (fa y)
     ;
-    value (run1 : af2 'x 'y 'a -> 'x -> af 'y 'a) = apply;
+    value (run1 : af2 'x 'y 'a -> 'x -> af 'y 'a) af2 x = af2 x;
     value (run2 : af2 'x 'y 'a -> 'x -> 'y -> 'a) af2 x y = af2 x y;
   end
 ;

File src/dbi/dbi_pg.ml

View file
 ;
 
 
-type typer 'a 'r = Postgresql.ftype -> bool -> string -> ('a -> 'r) -> 'r
+type ident = string
+;
+
+
+type record_signature = 
+  { rs_names : array ident
+  ; rs_types : array P.ftype
+  }
+;
+
+
+type record =
+  { rres : P.result
+  ; rrow : int
+  }
+;
+
+
+type colnum = int
+;
+
+
+type typer 'a 'r = record -> colnum -> ('a -> 'r) -> 'r
 ;
 
 
 (* строгий, чоткий, кидает исключения: *)
 module Typer
- :
-  sig
-    value string : typer string 'a;
-  end
  =
   struct
 
     ;
 
 
-    type typer2 'a 'r = (typer 'a 'r * typer (option 'a) 'r)
+    type typer2 'a 'r =
+      { notnull : !'r . typer 'a 'r
+      ; nullable : !'r . typer (option 'a) 'r
+      }
     ;
 
-    (* returns (notnull, nullable) *)
 
-    value common ~want_ftype ~check_ftype ~convert : typer2 _ _ =
-      ( fun ftype isnull untyped func ->
+ftype isnull untyped
+
+    value common ~want_ftype ~check_ftype ~convert =
+      { notnull = fun record colnum func ->
           ( do_check ~nullable:False ~check_ftype ~want_ftype ~ftype
           ; if isnull
             then
           ; try func (convert untyped)
             with [e -> convert_error ~want_ftype e]
           )
-      , fun ftype isnull untyped func ->
+      ; nullable = fun ... func ->
           ( do_check ~nullable:True ~check_ftype ~want_ftype ~ftype
           ; try
               func (if isnull then None else Some (convert untyped))
             with [e -> convert_error ~want_ftype e]
           )
-      )
+      }
     ;
 
     value string_check ftype =
       ]
     ;
 
-    value (astring, astring_opt) : typer2 string _ = common
-      ~want_ftype:"string (char, text, name, varchar)"
-      ~check_ftype:string_check
-      ~convert:identity
+    value { notnull = string ; nullable = string_opt } =
+      common
+        ~want_ftype:"string (char, text, name, varchar)"
+        ~check_ftype:string_check
+        ~convert:identity
     ;
 
-    value string x = astring x
+    value { notnull = binary ; nullable = binary_opt } =
+      common
+        ~want_ftype:"bytea (blob, binary)"
+        ~check_ftype:((=) P.BYTEA)
+        ~convert:identity
     ;
 
-    value (binary, binary_opt) : typer2 string _ = common
-      ~want_ftype:"bytea"
-      ~check_ftype:((=) P.BYTEA)
-      ~convert:identity
-    ;
+    value { notnull = number ; nullable = number_opt } = 
+      common
+        ~want_ftype:"numeric (number, decimal)"
+        ~check_ftype:((=) P.NUMERIC)
+        ~convert:
+    | P.NUMERIC -> `Num (Num.num_of_string x)
 
   end
 ;
 ;
 
 
-type ident = string
-;
-
-
-type record_signature = 
-  { rs_names : array ident
-  ; rs_types : array Postgresql.ftype
-  }
-;
-
-
 class result
   ['v]
   (entype : P.ftype -> ~isnull:bool -> string -> 'v)

File src/dbi/decimal.ml

View file
 open Am_All
 ;
 
-type t = private
-  { num : Num.t
+type t = (*private*)
+  { num : Num.num
   ; scale : int
   }
 ;
   inner ~scale:0 ~found:False 0
   where rec inner ~scale ~found i =
     if i = String.length s
-    then a
+    then
+      scale
     else
       let c = s.[i] in
       match (found, scale, is_decimal_point c) with
 ;
 
 
-value of_string s =
-  let n =
+value of_string_scale str scale
+  let num =
     try
-      num_of_string s
+      num_of_string str
     with
-    [ e -> invalid_arg "Decimal.of_string %S: %s" s (Printexc.to_string e) ]
-  in
-  let scale = get_scale s
+    [ e -> invalid_arg "Decimal.of_string %S: %s" str (Printexc.to_string e) ]
   in
     make ~num ~scale
 ;
 
 
+value of_string str =
+  let scale = get_scale str in
+  of_string_scale str scale
+;
+
+
 value maxscale op = fun a b ->
-  make ~num: (op a b) ~scale: (max a.scale b.scale)
+  make ~num: (op a.num b.num) ~scale: (max a.scale b.scale)
 ;