From 8bdaaefa3c16bee3fc8b3dfb5c98340d07221b0c Mon Sep 17 00:00:00 2001
From: ygrek <ygrek@autistici.org>
Date: Wed, 6 May 2009 10:52:21 +0300
Subject: [PATCH] Correct type for params in subexpressions

assign_types threw away types inferred for subexpressions
move small utility functions to apply.ml
---
 apply.ml     |  5 +++++
 listMore.ml  |  2 +-
 main.ml      |  5 +----
 operators.ml |  1 -
 syntax.ml    | 21 +++++++++++++++++++--
 5 files changed, 26 insertions(+), 8 deletions(-)
 create mode 100644 apply.ml

diff --git a/apply.ml b/apply.ml
new file mode 100644
index 0000000..f7d7630
--- /dev/null
+++ b/apply.ml
@@ -0,0 +1,5 @@
+
+external id : 'a -> 'a = "%identity"
+let catch f x = try Some (f x) with _ -> None
+let tee f x = f x; x
+
diff --git a/listMore.ml b/listMore.ml
index 01b24e3..f40e0a4 100644
--- a/listMore.ml
+++ b/listMore.ml
@@ -1,6 +1,6 @@
 (* *)
 
-open Operators
+open Apply
 
 module List = 
 struct
diff --git a/main.ml b/main.ml
index 58f283b..e517f43 100644
--- a/main.ml
+++ b/main.ml
@@ -6,6 +6,7 @@ open Printf
 open Operators
 open ListMore
 open ExtString
+open Apply
 
 module L = List
 module S = String
@@ -34,10 +35,6 @@ let show_one ((s,p),props) =
   RA.Scheme.print s;
   print_endline (Stmt.params_to_string p)
 
-let catch f x = try Some (f x) with _ -> None
-
-let tee f x = f x; x
-
 let parse_sql s =
   s >> statements >> L.map parse_one 
   >> L.filter_valid 
diff --git a/operators.ml b/operators.ml
index c85f741..6fa9608 100644
--- a/operators.ml
+++ b/operators.ml
@@ -2,4 +2,3 @@
 
 let (&) f g = function x -> f (g x)
 let (>>) x f = f x
-external id : 'a -> 'a = "%identity"
diff --git a/syntax.ml b/syntax.ml
index d9b5b1e..893fdb1 100644
--- a/syntax.ml
+++ b/syntax.ml
@@ -3,6 +3,7 @@
 open Stmt
 open Operators
 open ListMore
+open Apply
 
 type expr = [ `Value of Sql.Type.t (** literal value *)
             | `Param of param
@@ -11,6 +12,12 @@ type expr = [ `Value of Sql.Type.t (** literal value *)
             ]
             deriving (Show)
 
+type expr_q = [ `Value of Sql.Type.t (** literal value *)
+            | `Param of param
+            | `Func of Sql.Type.t option * expr_q list (** return type, parameters *)
+            ]
+            deriving (Show)
+
 let expr_to_string = Show.show<expr>
 
 type column = 
@@ -48,10 +55,15 @@ let assign_types expr =
     | `Func (ret,l) -> 
 (** Assumption: sql functions/operators have type scheme 'a -> 'a -> 'b
     i.e. all parameters of some equal type *)
-        let t = match l >> List.map typeof >> List.map snd >> List.filter_valid with
+        let (l,t) = l >> List.map typeof >> List.split in
+        let t = match List.filter_valid t with
         | [] -> None
         | h::t -> if List.for_all ((=) h) t then Some h else None
         in
+(*
+        print_endline (Show.show<expr_q list>(l));
+        print_endline (Show.show<Sql.Type.t option>(t));
+*)
         let assign = function
         | `Param (n,None) -> `Param (n,t)
         | x -> x
@@ -62,8 +74,13 @@ let assign_types expr =
   in
   typeof expr
 
+let show_e e = Show.show<expr> (e:>expr) >> print_endline
+
 let resolve_types tables expr =
-  expr >> resolve_columns tables >> assign_types
+  expr 
+  >> resolve_columns tables 
+(*   >> tee show_e  *)
+  >> assign_types
 
 let get_scheme columns tables =
   let all = tables >> List.map snd >> List.flatten in
-- 
2.11.4.GIT