[MLton-commit] r5217

Wesley Terpstra wesley at mlton.org
Fri Feb 16 07:23:38 PST 2007


binding aggregate functions now works
----------------------------------------------------------------------

U   mltonlib/trunk/ca/terpstra/sqlite3/demo.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/function.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
U   mltonlib/trunk/ca/terpstra/sqlite3/prim.sml
U   mltonlib/trunk/ca/terpstra/sqlite3/sql.sig
U   mltonlib/trunk/ca/terpstra/sqlite3/sql.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/ca/terpstra/sqlite3/demo.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/demo.sml	2007-02-16 14:43:20 UTC (rev 5216)
+++ mltonlib/trunk/ca/terpstra/sqlite3/demo.sml	2007-02-16 15:23:37 UTC (rev 5217)
@@ -15,10 +15,14 @@
   fun concat (a & b) = a ^ b
   fun debug v = Vector.app (fn s => print (s ^ "\n")) v
   fun glom (s & i) = if i = 0 then raise SQL.Error "bad integer" else s ^ Int.toString i
+  val sum2 = { init = fn () => 0, 
+               step = fn (i, (j & k)) => i+j+k, 
+               finish = fn x => x }
   val () = SQL.registerFunction  (db, "wes", fnS iS iS $ concat)
   val () = SQL.registerFunction  (db, "debug", fnN iAS $ debug)
   val () = SQL.registerFunction  (db, "glom", fnS iS iI $ glom)
   val () = SQL.registerCollation (db, "sless", String.compare)
+  val () = SQL.registerAggregate (db, "sum2", aggrI iI iI $ sum2)
 end
 
 local

Modified: mltonlib/trunk/ca/terpstra/sqlite3/function.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/function.sml	2007-02-16 14:43:20 UTC (rev 5216)
+++ mltonlib/trunk/ca/terpstra/sqlite3/function.sml	2007-02-16 15:23:37 UTC (rev 5217)
@@ -1,18 +1,27 @@
 structure Function =
    struct
-      type t = (Prim.context * Prim.value vector -> unit) * int
+      type scalar = (Prim.context * Prim.value vector -> unit) * int
+      type aggregate = Prim.aggregate * int
       
+      type ('a, 'b, 'c) folder = {
+         init: unit -> 'a,
+         step: 'a * 'b -> 'a,
+         finish: 'a -> 'c
+      }
+      
       type 'a iF = Prim.value vector -> 'a
       type ('b, 'c) iN = Prim.value vector * (unit -> 'b) -> 'c
       type ('a, 'b, 'c) acc = int * 'a iF * ('b, 'c) iN
       
+      type ('v, 'a, 'b, 'c, 'd, 'e) fnX = 
+          ((unit, 'a, 'a) acc, ('b, 'c, 'd) acc, ('b -> 'v) -> scalar, 'e) Fold.t 
+      type ('v, 'a, 'b, 'c, 'd, 'e, 'f) aggrX = 
+          ((unit, 'a, 'a) acc, ('b, 'c, 'd) acc, ('f, 'b, 'v) folder -> aggregate, 'e) Fold.t
+      
       type ('v, 'a, 'b, 'c, 'd, 'e, 'f) input = 
           (('a, 'v, 'b) acc, ('b, 'c, ('b, 'c) pair) acc, 'd, 'e, 'f) Fold.step0
-      type ('v, 'a, 'b, 'c, 'd, 'e) fnX = 
-          ((unit, 'a, 'a) acc, ('b, 'c, 'd) acc, ('b -> 'v) -> t, 'e) Fold.t 
       type ('v, 'a, 'b, 'c) inputA = 
           ((unit, unit, unit) acc, ('v vector, unit, unit) acc, 'a, 'b, 'c) Fold.step0
-            
       
       val iI0 = 0
       fun iF0 _ = ()
@@ -29,6 +38,31 @@
       fun fnX z = fnMap Prim.resultX z
       fun fnN z = fnMap Prim.resultN z
       
+      fun aggrMap r = Fold.fold ((iI0, iF0, iN0),
+                               fn (iI, iF, _) => fn { init, step, finish } =>
+                               let
+                                  fun finish1 c = r (c, finish (init ()))
+                                  fun step1 x =
+                                     let
+                                        val acc = ref (init ())
+                                        fun stepX (_, v) = 
+                                           (acc := step (!acc, iF v); 
+                                            Prim.AGGREGATE (stepX, finishX))
+                                        and finishX c = r (c, finish (!acc))
+                                      in
+                                        stepX x
+                                      end
+                               in
+                                  (Prim.AGGREGATE (step1, finish1), iI)
+                               end)
+      fun aggrB z = aggrMap Prim.resultB z
+      fun aggrR z = aggrMap Prim.resultR z
+      fun aggrI z = aggrMap Prim.resultI z
+      fun aggrZ z = aggrMap Prim.resultZ z
+      fun aggrS z = aggrMap Prim.resultS z
+      fun aggrX z = aggrMap Prim.resultX z
+      fun aggrN z = aggrMap Prim.resultN z
+      
       (* terminate an expression with this: *)
       val $ = $
       

Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sig	2007-02-16 14:43:20 UTC (rev 5216)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sig	2007-02-16 15:23:37 UTC (rev 5217)
@@ -80,7 +80,7 @@
       val resultX: context * storage -> unit
       
       datatype aggregate = 
-         AGGR of (context * value vector -> aggregate) * (context -> unit)
+         AGGREGATE of (context * value vector -> aggregate) * (context -> unit)
       val createFunction:  db * string * (context * value vector -> unit) * int -> unit
       val createCollation: db * string * (string * string -> order) -> unit
       val createAggregate: db * string * aggregate * int -> unit

Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sml	2007-02-16 14:43:20 UTC (rev 5216)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sml	2007-02-16 15:23:37 UTC (rev 5217)
@@ -291,8 +291,8 @@
       
       (************************************************* Aggregate functions *)
       datatype aggregate = 
-         AGGR of (Context.t * Value.t vector -> aggregate) * 
-                 (Context.t -> unit)
+         AGGREGATE of (Context.t * Value.t vector -> aggregate) * 
+                      (Context.t -> unit)
       val aginit = Buffer.empty ()
       val agstep = Buffer.empty ()
       fun fetchAggr context =
@@ -318,7 +318,7 @@
             fun get i = Value.fromPtr (MLton.Pointer.getPointer (args, i))
             val args = Vector.tabulate (numargs, get)
             fun error s = Presult_error (context, CStr.fromString s, String.size s)
-            val AGGR (step, _) = Buffer.sub (agstep, ids)
+            val AGGREGATE (step, _) = Buffer.sub (agstep, ids)
          in
             Buffer.update (agstep, ids, step (context, args))
             handle Error x => error ("fatal: " ^ x)
@@ -330,7 +330,7 @@
          let
             val ids = fetchAggr context
             fun error s = Presult_error (context, CStr.fromString s, String.size s)
-            val AGGR (_, final) = Buffer.sub (agstep, ids)
+            val AGGREGATE (_, final) = Buffer.sub (agstep, ids)
          in
             final context
             handle Error x => error ("fatal: " ^ x)

Modified: mltonlib/trunk/ca/terpstra/sqlite3/sql.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/sql.sig	2007-02-16 14:43:20 UTC (rev 5216)
+++ mltonlib/trunk/ca/terpstra/sqlite3/sql.sig	2007-02-16 15:23:37 UTC (rev 5217)
@@ -114,22 +114,36 @@
        *   fun concat (a & b) = a ^ b
        *   fun pi () = 3.14159
        *   fun dump v = Vector.app (fn s => print (s ^ "\n")) v
+       *
+       *   val sum2 = { init = fn () => 0, 
+       *                step = fn (i, (j & k)) => i+j+k, 
+       *                finish = fn x => x }
        * in
        *   val () = SQL.registerFunction (db, "concat", fnS iS iS $ concat)
        *   val () = SQL.registerFunction (db, "pi", fnR $ pi)
        *   val () = SQL.registerFunction (db, "dump", fnN iAS $ dump)
+       *   val () = SQL.registerAggregate (db, "sum2", aggrI iI iI $ sum2)
        * end
        *)
       structure Function:
          sig
-            type t
+            type scalar
+            type aggregate
             
+            type ('a, 'b, 'c) folder = {
+               init: unit -> 'a,
+               step: 'a * 'b -> 'a,
+               finish: 'a -> 'c
+            }
+            
             (* don't look at this: *)
             type ('a, 'b, 'c) acc
+            type ('v, 'a, 'b, 'c, 'd, 'e) fnX = 
+               ((unit, 'a, 'a) acc, ('b, 'c, 'd) acc, ('b -> 'v) -> scalar, 'e) Fold.t 
+            type ('v, 'a, 'b, 'c, 'd, 'e, 'f) aggrX = 
+               ((unit, 'a, 'a) acc, ('b, 'c, 'd) acc, ('f, 'b, 'v) folder -> aggregate, 'e) Fold.t 
             type ('v, 'a, 'b, 'c, 'd, 'e, 'f) input = 
                (('a, 'v, 'b) acc, ('b, 'c, ('b, 'c) pair) acc, 'd, 'e, 'f) Fold.step0
-            type ('v, 'a, 'b, 'c, 'd, 'e) fnX = 
-               ((unit, 'a, 'a) acc, ('b, 'c, 'd) acc, ('b -> 'v) -> t, 'e) Fold.t 
             type ('v, 'a, 'b, 'c) inputA = 
                ((unit, unit, unit) acc, ('v vector, unit, unit) acc, 'a, 'b, 'c) Fold.step0
             
@@ -142,6 +156,15 @@
             val fnX: (storage,            'a, 'b, 'c, 'd, 'e) fnX
             val fnN: (unit,               'a, 'b, 'c, 'd, 'e) fnX
             
+            (* Return types of the aggregate *)
+            val aggrB: (Word8Vector.vector, 'a, 'b, 'c, 'd, 'e, 'f) aggrX
+            val aggrR: (real,               'a, 'b, 'c, 'd, 'e, 'f) aggrX
+            val aggrI: (int,                'a, 'b, 'c, 'd, 'e, 'f) aggrX
+            val aggrZ: (Int64.int,          'a, 'b, 'c, 'd, 'e, 'f) aggrX
+            val aggrS: (string,             'a, 'b, 'c, 'd, 'e, 'f) aggrX
+            val aggrX: (storage,            'a, 'b, 'c, 'd, 'e, 'f) aggrX
+            val aggrN: (unit,               'a, 'b, 'c, 'd, 'e, 'f) aggrX
+            
             val $ : 'a * ('a -> 'b) -> 'b
             
             (* Input parameters to the function *)
@@ -161,6 +184,8 @@
             val iAX: (storage,            'a, 'b, 'c) inputA
          end
       
-      val registerFunction:  db * string * Function.t -> unit
+      (* SQL.Error exceptions in callbacks are propogated ok. Others not. *)
+      val registerFunction:  db * string * Function.scalar -> unit
+      val registerAggregate: db * string * Function.aggregate -> unit
       val registerCollation: db * string * (string * string -> order) -> unit
    end

Modified: mltonlib/trunk/ca/terpstra/sqlite3/sql.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/sql.sml	2007-02-16 14:43:20 UTC (rev 5216)
+++ mltonlib/trunk/ca/terpstra/sqlite3/sql.sml	2007-02-16 15:23:37 UTC (rev 5217)
@@ -96,6 +96,7 @@
             end
       end
       
-      fun registerFunction (db, s, (f, i)) = Prim.createFunction (db, s, f, i)
+      fun registerFunction  (db, s, (f, i)) = Prim.createFunction (db, s, f, i)
+      fun registerAggregate (db, s, (a, i)) = Prim.createAggregate(db, s, a, i)
       val registerCollation = Prim.createCollation
    end




More information about the MLton-commit mailing list