add lots of unit tests to postgresql

select queries are generated now

extra/db/db.factor

@@ -23,12 +23,12 @@ HOOK: db-close db ( handle -- )
         db-handle db-close
     ] with-variable ;
 
-TUPLE: statement sql params handle bound? slot-names ;
+TUPLE: statement handle sql slot-names bind-params bound? ;
 TUPLE: simple-statement ;
 TUPLE: prepared-statement ;
 
 HOOK: <simple-statement> db ( str -- statement )
-HOOK: <prepared-statement> db ( str -- statement )
+HOOK: <prepared-statement> db ( str slot-names -- statement )
 GENERIC: prepare-statement ( statement -- )
 GENERIC: bind-statement* ( obj statement -- )
 GENERIC: reset-statement ( statement -- )
@@ -47,7 +47,7 @@ GENERIC: more-rows? ( result-set -- ? )
 : bind-statement ( obj statement -- )
     dup statement-bound? [ dup reset-statement ] when
     [ bind-statement* ] 2keep
-    [ set-statement-params ] keep
+    [ set-statement-bind-params ] keep
     t swap set-statement-bound? ;
 
 : init-result-set ( result-set -- )
@@ -55,7 +55,7 @@ GENERIC: more-rows? ( result-set -- ? )
     0 swap set-result-set-n ;
 
 : <result-set> ( query handle tuple -- result-set )
-    >r >r { statement-sql statement-params } get-slots r>
+    >r >r { statement-sql statement-bind-params } get-slots r>
     {
         set-result-set-sql
         set-result-set-params

extra/db/postgresql/lib/lib.factor

@@ -37,8 +37,8 @@ IN: db.postgresql.lib
 : do-postgresql-bound-statement ( statement -- res )
     >r db get db-handle r>
     [ statement-sql ] keep
-    [ statement-params length f ] keep
+    [ statement-bind-params length f ] keep
-    statement-params
+    statement-bind-params
     [ first number>string* malloc-char-string ] map >c-void*-array
     f f 0 PQexecParams
     dup postgresql-result-ok? [

extra/db/postgresql/postgresql-tests.factor

@@ -111,6 +111,8 @@ IN: temporary
 ] unit-test
 
 
+: with-dummy-db ( quot -- )
+    >r T{ postgresql-db } db r> with-variable ;
 
 ! TEST TUPLE DB
 
@@ -119,8 +121,8 @@ TUPLE: puppy id name age ;
     { set-puppy-name set-puppy-age } puppy construct ;
 
 puppy "PUPPY" {
-    { "id" "ID" +native-id+ }
+    { "id" "ID" +native-id+ +not-null+ }
-    { "name" "NAME" TEXT }
+    { "name" "NAME" { VARCHAR 256 } }
     { "age" "AGE" INTEGER }
 } define-persistent
 
@@ -129,7 +131,7 @@ TUPLE: kitty id name age ;
     { set-kitty-name set-kitty-age } kitty construct ;
 
 kitty "KITTY" {
-    { "id" "ID" +native-id+ }
+    { "id" "ID" INTEGER +assigned-id+ }
     { "name" "NAME" TEXT }
     { "age" "AGE" INTEGER }
 } define-persistent
@@ -137,20 +139,226 @@ kitty "KITTY" {
 TUPLE: basket id puppies kitties ;
 basket "BASKET"
 {
-    { "id" "ID" +native-id+ }
+    { "id" "ID" +native-id+ +not-null+ }
     { "location" "LOCATION" TEXT }
     { "puppies" { +has-many+ puppy } }
     { "kitties" { +has-many+ kitty } }
 } define-persistent
 
+! Create table
 [
-    { "name" "age" }
+    "create table puppy(id serial primary key not null, name varchar 256, age integer);"
-    ! "insert into table puppy(name, age) values($1, $2);"
-    "select add_puppy($1, $2, $3);"
 ] [
     T{ postgresql-db } db [
-        "Mr Clunkers" 3 <puppy>
+        puppy dup db-columns swap db-table create-table-sql >lower
-        class dup db-columns swap db-table insert-sql* >lower
     ] with-variable
 ] unit-test
 
+[
+    "create table kitty(id integer primary key, name text, age integer);"
+] [
+    T{ postgresql-db } db [
+        kitty dup db-columns swap db-table create-table-sql >lower
+    ] with-variable
+] unit-test
+
+[
+    "create table basket(id serial primary key not null, location text);"
+] [
+    T{ postgresql-db } db [
+        basket dup db-columns swap db-table create-table-sql >lower
+    ] with-variable
+] unit-test
+
+! Create function
+[
+    "create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;"
+] [
+    T{ postgresql-db } db [
+        puppy dup db-columns swap db-table create-function-sql >lower
+    ] with-variable
+] unit-test
+
+! Drop table
+
+[
+    "drop table puppy;"
+] [
+    T{ postgresql-db } db [
+        puppy db-table drop-table-sql >lower
+    ] with-variable
+] unit-test
+
+[
+    "drop table kitty;"
+] [
+    T{ postgresql-db } db [
+        kitty db-table drop-table-sql >lower
+    ] with-variable
+] unit-test
+
+[
+    "drop table basket;"
+] [
+    T{ postgresql-db } db [
+        basket db-table drop-table-sql >lower
+    ] with-variable
+] unit-test
+
+
+! Drop function
+[
+    "drop function add_puppy(varchar, integer);"
+] [
+    T{ postgresql-db } db [
+        puppy dup db-columns swap db-table drop-function-sql >lower
+    ] with-variable
+] unit-test
+
+! Insert
+[
+    "select add_puppy($1, $2);"
+    {
+        T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } }
+        T{ sql-spec f "age" "AGE" INTEGER { } }
+    }
+    {
+        T{ sql-spec f "id" "ID" +native-id+ { +not-null+ } +native-id+ }
+    }
+] [
+    T{ postgresql-db } db [
+        puppy dup db-columns swap db-table insert-sql* >r >r >lower r> r>
+    ] with-variable
+] unit-test
+
+[
+    "insert into kitty(id, name, age) values($1, $2, $3);"
+    {
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            INTEGER
+            { +assigned-id+ }
+            +assigned-id+
+        }
+        T{ sql-spec f "name" "NAME" TEXT { } f }
+        T{ sql-spec f "age" "AGE" INTEGER { } f }
+    }
+    { }
+] [
+    T{ postgresql-db } db [
+        kitty dup db-columns swap db-table insert-sql* >r >r >lower r> r>
+    ] with-variable
+] unit-test
+
+! Update
+[
+    "update puppy set name = $1, age = $2 where id = $3"
+    {
+        T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
+        T{ sql-spec f "age" "AGE" INTEGER { } f }
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            +native-id+
+            { +not-null+ }
+            +native-id+
+        }
+    }
+    { }
+] [
+    T{ postgresql-db } db [
+        puppy dup db-columns swap db-table update-sql* >r >r >lower r> r>
+    ] with-variable
+] unit-test
+
+[
+    "update kitty set name = $1, age = $2 where id = $3"
+    {
+        T{ sql-spec f "name" "NAME" TEXT { } f }
+        T{ sql-spec f "age" "AGE" INTEGER { } f }
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            INTEGER
+            { +assigned-id+ }
+            +assigned-id+
+        }
+    }
+    { }
+] [
+    T{ postgresql-db } db [
+        kitty dup db-columns swap db-table update-sql* >r >r >lower r> r>
+    ] with-variable
+] unit-test
+
+! Delete
+[
+    "delete from puppy where id = $1"
+    {
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            +native-id+
+            { +not-null+ }
+            +native-id+
+        }
+    }
+    { }
+] [
+    T{ postgresql-db } db [
+        puppy dup db-columns swap db-table delete-sql* >r >r >lower r> r>
+    ] with-variable
+] unit-test
+
+[
+    "delete from KITTY where ID = $1"
+    {
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            INTEGER
+            { +assigned-id+ }
+            +assigned-id+
+        }
+    }
+    { }
+] [
+    T{ postgresql-db } db [
+        kitty dup db-columns swap db-table delete-sql*
+    ] with-variable
+] unit-test
+
+! Select
+[
+    "select from PUPPY ID, NAME, AGE where NAME = $1;"
+    { T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } }
+    {
+        T{
+            sql-spec
+            f
+            "id"
+            "ID"
+            +native-id+
+            { +not-null+ }
+            +native-id+
+        }
+        T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
+        T{ sql-spec f "age" "AGE" INTEGER { } f }
+    }
+] [
+    T{ postgresql-db } db [
+        T{ puppy f f "Mr. Clunkers" }
+        select-by-slots-sql
+    ] with-variable
+] unit-test

extra/db/postgresql/postgresql.factor

@@ -4,7 +4,7 @@ USING: arrays assocs alien alien.syntax continuations io
 kernel math math.parser namespaces prettyprint quotations
 sequences debugger db db.postgresql.lib db.postgresql.ffi
 db.tuples db.types tools.annotations math.ranges
-combinators sequences.lib classes ;
+combinators sequences.lib classes locals words ;
 IN: db.postgresql
 
 TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@@ -39,7 +39,7 @@ M: postgresql-db dispose ( db -- )
     >r <postgresql-db> r> with-disposal ;
 
 M: postgresql-statement bind-statement* ( seq statement -- )
-    set-statement-params ;
+    set-statement-bind-params ;
 
 M: postgresql-statement reset-statement ( statement -- )
     drop ;
@@ -68,7 +68,7 @@ M: postgresql-statement insert-statement ( statement -- id )
     query-results [ 0 row-column ] with-disposal string>number ;
 
 M: postgresql-statement query-results ( query -- result-set )
-    dup statement-params [
+    dup statement-bind-params [
         over [ bind-statement ] keep
         do-postgresql-bound-statement
     ] [
@@ -96,7 +96,7 @@ M: postgresql-result-set dispose ( result-set -- )
 M: postgresql-statement prepare-statement ( statement -- )
     [
         >r db get db-handle "" r>
-        dup statement-sql swap statement-params
+        dup statement-sql swap statement-bind-params
         length f PQprepare postgresql-error
     ] keep set-statement-handle ;
 
@@ -104,9 +104,10 @@ M: postgresql-db <simple-statement> ( sql -- statement )
     { set-statement-sql } statement construct
     <postgresql-statement> ;
 
-M: postgresql-db <prepared-statement> ( sql -- statement )
+M: postgresql-db <prepared-statement> ( pair -- statement )
-    { set-statement-sql } statement construct
+    ?first2
-    <postgresql-statement> ;
+    { set-statement-sql set-statement-slot-names }
+    statement construct <postgresql-statement> ;
 
 M: postgresql-db begin-transaction ( -- )
     "BEGIN" sql-command ;
@@ -117,134 +118,179 @@ M: postgresql-db commit-transaction ( -- )
 M: postgresql-db rollback-transaction ( -- )
     "ROLLBACK" sql-command ;
 
-: insert-function ( columns table -- sql types )
+: modifiers% ( spec -- )
+    sql-spec-modifiers
+    [ lookup-modifier ] map
+    " " join
+    dup empty? [ drop ] [ " " % % ] if ;
+
+SYMBOL: postgresql-counter
+: bind% ( spec -- )
+    1,
+    CHAR: $ 0,
+    postgresql-counter [ inc ] keep get 0# ;
+
+: postgresql-make ( quot -- )
+    [ postgresql-counter off ] swap compose
+    { "" { } { } } nmake ;
+
+:: create-table-sql | specs table |
     [
-        >r remove-id r>
+        "create table " % table %
-        "create function add_" % dup %
         "(" %
-        over [ "," % ]
+        specs [ ", " % ] [
-        [ third dup array? [ first ] when >sql-type-string % ] interleave
+            dup sql-spec-column-name %
-        ")" %
+            " " %
-        " returns bigint as '" %
+            dup sql-spec-type t lookup-type %
+            modifiers%
+        ] interleave ");" %
+    ] "" make ;
 
-        2dup "insert into " %
+:: create-function-sql | specs table |
-        %
+    [
-        "(" %
+        [let | specs [ specs remove-id ] |
-        dup [ ", " % ] [ second % ] interleave
+            "create function add_" 0% table 0%
-        ") " %
+            "(" 0%
-        " values (" %
+            specs [ "," 0% ]
-        length [1,b] [ ", " % ] [ "$" % # ] interleave
+            [
-        "); " %
+                sql-spec-type f lookup-type 0%
-
+            ] interleave
-        "select currval(''" % % "_id_seq'');' language sql;" %
+            ")" 0%
-        drop
+            " returns bigint as '" 0%
-    ] "" make f ;
+
-
+            "insert into " 0%
-: drop-function ( columns table -- sql )
+            table 0%
+            "(" 0%
+            specs [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+            ") values(" 0%
+            specs [ ", " 0% ] [ bind% ] interleave
+            "); " 0%
+
+            "select currval(''" 0% table 0% "_id_seq'');' language sql;" 0%
+        ]
+    ] postgresql-make 2drop ;
+
+: drop-function-sql ( specs table -- sql )
     [
-        >r remove-id r>
         "drop function add_" % %
         "(" %
-        [ "," % ] [ third >sql-type-string % ] interleave
+        remove-id
-        ")" %
+        [ ", " % ] [ sql-spec-type f lookup-type % ] interleave
-    ] "" nmake ;
-
-! M: postgresql-db create-sql ( columns table -- seq )
-    ! [
-        ! [
-            ! 2dup
-            ! "create table " % %
-            ! " (" % [ ", " % ] [
-                ! dup second % " " %
-                ! dup third >sql-type-string % " " %
-                ! sql-modifiers " " join %
-            ! ] interleave "); " %
-        ! ] "" make ,
-! 
-        ! over native-id? [ insert-function , ] [ 2drop ] if
-    ! ] { } make ;
-
-M: postgresql-db drop-sql ( columns table -- seq )
-    [
-        [
-            dup "drop table " % % ";" %
-        ] "" make ,
-        over native-id? [ drop-function , ] [ 2drop ] if
-    ] { } make ;
-
-M: postgresql-db insert-sql* ( columns table -- sql slots )
-    [
-        "select add_" % %
-        "(" %
-        dup length [1,b] [ ", " % ] [ "$" % # ] interleave
         ");" %
     ] "" make ;
 
-M: postgresql-db update-sql* ( columns table -- sql slots )
+: drop-table-sql ( table -- sql )
     [
-        "update " %
+        "drop table " % % ";" %
-        %
+    ] "" make ;
-        " set " %
+
+M: postgresql-db create-sql ( specs table -- seq )
+    [
+        2dup create-table-sql ,
+        over find-primary-key native-id?
+        [ create-function-sql , ] [ 2drop ] if
+    ] { } make ;
+
+M: postgresql-db drop-sql ( specs table -- seq )
+    [
+        dup drop-table-sql ,
+        over find-primary-key native-id?
+        [ drop-function-sql , ] [ 2drop ] if
+    ] { } make ;
+
+: insert-table-sql ( specs table -- sql in-specs out-specs )
+    [
+        "insert into " 0% 0%
+        "(" 0%
+        dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+        ")" 0%
+
+        " values(" 0%
+        [ ", " 0% ] [ bind% ] interleave
+        ");" 0%
+    ] postgresql-make ;
+
+: insert-function-sql ( specs table -- sql in-specs out-specs )
+    [
+        "select add_" 0% 0%
+        "(" 0%
+        dup find-primary-key 2,
+        remove-id
+        [ ", " 0% ] [ bind% ] interleave
+        ");" 0%
+    ] postgresql-make ;
+
+M: postgresql-db insert-sql* ( specs table -- sql in-specs out-specs )
+    over find-primary-key native-id?
+    [ insert-function-sql ] [ insert-table-sql ] if ;
+
+M: postgresql-db update-sql* ( specs table -- sql in-specs out-specs )
+    [
+        "update " 0% 0%
+        " set " 0%
         dup remove-id
-        dup length [1,b] swap 2array flip
+        [ ", " 0% ]
-        [ ", " % ] [ first2 second % " = $" % # ] interleave
+        [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
-        " where " %
+        " where " 0%
-        [ primary-key? ] find nip second dup % " = $" % length 2 + #
+        find-primary-key
-    ] "" make ;
+        dup sql-spec-column-name 0% " = " 0% bind%
+    ] postgresql-make ;
 
-M: postgresql-db delete-sql* ( columns table -- slot-names sql )
+M: postgresql-db delete-sql* ( specs table -- sql in-specs out-specs )
     [
-        "delete from " %
+        "delete from " 0% 0%
-        %
+        " where " 0%
-        " where " %
+        find-primary-key
-        first second % " = $1" %
+        dup sql-spec-column-name 0% " = " 0% bind%
-    ] "" make ;
+    ] postgresql-make ;
 
-: column-name% ( spec -- )
+: select-by-slots-sql ( tuple -- sql in-specs out-specs )
-    dup sql-spec-column-name 0%
-    sql-spec-type >sql-type-string 1, ;
-
-: column-names% ( class -- )
-    db-columns [ "," 0, ] [ column-name% ] interleave ;
-
-M: postgresql-db column-bind% ( spec -- )
-    
-    
-    ;
-
-
-! : select-foreign-table-sql ( tuple relation -- )
-! ! select id, name, age from puppy, basket where puppy.basket_id = basket.id
-    ! "select " 0% 
-    ! ;
-! TODO
-: select-relations-sql ( tuple -- seq )
-    ! seq -- { sql types }
-    dup class db-relations [
-        [
-            ! select-foreign-table-sql
-        ] { "" { } } 2 nmake
-    ] with { } map>assoc ;
-
-! TODO
-: select-by-slots-sql ( tuple -- sql )
-    dup tuple>filled-slots
-    ;
-
-
-M: postgresql-db select-sql ( tuple -- sql slot-names )
     [
-        
+        "select from " 0% dup class db-table 0%
-    ] { } 2 nmake ;
+        " " 0%
+        dup class db-columns [ ", " 0% ]
+        [ dup sql-spec-column-name 0% 2, ] interleave
 
-M: postgresql-db tuple>params ( columns tuple -- obj )
+        dup class db-columns
+        [ sql-spec-slot-name swap get-slot-named ] with subset
+        " where " 0%
+        [ ", " 0% ]
+        [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
+        ";" 0%
+    ] postgresql-make ;
+
+! : select-with-relations ( tuple -- sql in-specs out-specs )
+
+M: postgresql-db select-sql ( tuple -- sql in-specs out-specs )
+    select-by-slots-sql ;
+
+M: postgresql-db tuple>params ( specs tuple -- obj )
     [ >r dup third swap first r> get-slot-named swap ]
     curry { } map>assoc ;
+
+M: postgresql-db type-table ( -- hash )
+    H{
+        { +native-id+ "integer" }
+        { TEXT "text" }
+        { VARCHAR "varchar" }
+        { INTEGER "integer" }
+    } ;
+
+M: postgresql-db create-type-table ( -- hash )
+    H{
+        { +native-id+ "serial primary key" }
+    } ;
+
+: postgresql-compound ( str n -- newstr )
+    dup number? [ "compound -- not a number" throw ] unless
+    number>string " " swap 3append ;
+
+M: postgresql-db compound-modifier ( str n -- newstr )
+    postgresql-compound ;
     
-: postgresql-db-modifiers ( -- hashtable )
+M: postgresql-db modifier-table ( -- hashtable )
     H{
         { +native-id+ "primary key" }
-        { +foreign-key+ "" }
         { +assigned-id+ "primary key" }
         { +autoincrement+ "autoincrement" }
         { +unique+ "unique" }
@@ -253,16 +299,5 @@ M: postgresql-db tuple>params ( columns tuple -- obj )
         { +not-null+ "not null" }
     } ;
 
-! M: postgresql-db sql-modifier>string ( modifier -- str )
+M: postgresql-db compound-type ( str n -- newstr )
-    ! dup array? [
+    postgresql-compound ;
-        ! first2
-        ! >r swap at r> number>string*
-        ! " " swap 3append
-    ! ] [
-        ! swap at
-    ! ] if ;
-! 
-! M: postgresql-db sql-modifiers* ( modifiers -- str )
-    ! postgresql-db-modifiers swap [
-        ! sql-modifier>string
-    ! ] with map [ ] subset ;

extra/db/tuples/tuples.factor

@@ -47,6 +47,7 @@ HOOK: insert-sql* db ( columns table -- sql slot-names )
 HOOK: update-sql* db ( columns table -- sql slot-names )
 HOOK: delete-sql* db ( columns table -- sql slot-names )
 HOOK: select-sql db ( tuple -- seq/statement )
+HOOK: select-relations-sql db ( tuple -- seq/statement )
 
 HOOK: row-column-typed db ( result-set n type -- sql )
 HOOK: sql-type>factor-type db ( obj type -- obj )
@@ -101,7 +102,8 @@ HOOK: tuple>params db ( columns tuple -- obj )
 : define-persistent ( class table columns -- )
     >r dupd "db-table" set-word-prop dup r>
     [ relation? ] partition swapd
-    [ spec>tuple ] map "db-columns" set-word-prop
+    [ spec>tuple ] map
+    "db-columns" set-word-prop
     "db-relations" set-word-prop ;
 
 : tuple>filled-slots ( tuple -- alist )
@@ -117,13 +119,17 @@ SYMBOL: building-seq
 
 : n, get-building-seq push ;
 : n% get-building-seq push-all ;
+: n# >r number>string r> n% ;
 
 : 0, 0 n, ;
 : 0% 0 n% ;
+: 0# 0 n# ;
 : 1, 1 n, ;
 : 1% 1 n% ;
+: 1# 1 n# ;
 : 2, 2 n, ;
 : 2% 2 n% ;
+: 2# 2 n# ;
 
 : nmake ( quot exemplars -- seqs )
     dup length dup zero? [ 1+ ] when

extra/db/types/types.factor

@@ -1,21 +1,38 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs db kernel math math.parser
-sequences continuations sequences.deep sequences.lib ;
+sequences continuations sequences.deep sequences.lib
+words ;
 IN: db.types
 
+TUPLE: sql-spec slot-name column-name type modifiers primary-key ;
 ! ID is the Primary key
+! +native-id+ can be a columns type or a modifier
 SYMBOL: +native-id+
+! +assigned-id+ can only be a modifier
 SYMBOL: +assigned-id+
 
-: primary-key? ( spec -- ? )
+: primary-key? ( obj -- ? )
-    [ { +native-id+ +assigned-id+ } member? ] contains? ;
+    { +native-id+ +assigned-id+ } member? ;
 
-: contains-id? ( columns id -- ? )
+: normalize-spec ( spec -- )
-    swap [ member? ] with contains? ;
+    dup sql-spec-type dup primary-key? [
-    
+        swap set-sql-spec-primary-key
-: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
+    ] [
-: native-id? ( columns -- ? ) +native-id+ contains-id? ;
+        drop dup sql-spec-modifiers [
+            primary-key?
+        ] deep-find
+        [ swap set-sql-spec-primary-key ] [ drop ] if*
+    ] if ;
+
+: find-primary-key ( specs -- obj )
+    [ sql-spec-primary-key ] find nip ;
+
+: native-id? ( spec -- ? )
+    sql-spec-primary-key +native-id+ = ;
+
+: assigned-id? ( spec -- ? )
+    sql-spec-primary-key +assigned-id+ = ;
 
 SYMBOL: +foreign-key+
 
@@ -31,7 +48,7 @@ SYMBOL: +not-null+
 SYMBOL: +has-many+
 
 : relation? ( spec -- ? )
-    [ +has-many+ = ] deep-find* nip ;
+    [ +has-many+ = ] deep-find ;
 
 SYMBOL: INTEGER
 SYMBOL: BIG_INTEGER
@@ -45,30 +62,15 @@ SYMBOL: VARCHAR
 SYMBOL: TIMESTAMP
 SYMBOL: DATE
 
-TUPLE: no-sql-type ;
-: no-sql-type ( -- * ) T{ no-sql-type } throw ;
-
-: number>string* ( n/str -- str )
-    dup number? [ number>string ] when ;
-
-: maybe-remove-id ( columns -- obj )
-    [ +native-id+ swap member? not ] subset ;
-
-: remove-relations ( columns -- newcolumns )
-    [ relation? not ] subset ;
-
-: remove-id ( columns -- obj )
-    [ primary-key? not ] subset ;
-
-! SQLite Types: http://www.sqlite.org/datatype3.html
-! NULL INTEGER REAL TEXT BLOB
-! PostgreSQL Types:
-! http://developer.postgresql.org/pgdocs/postgres/datatype.html
-
-TUPLE: sql-spec slot-name column-name type modifiers ;
-
 : spec>tuple ( spec -- tuple )
-    [ ?first3 ] keep 3 ?tail* sql-spec construct-boa ;
+    [ ?first3 ] keep 3 ?tail*
+    {
+        set-sql-spec-slot-name
+        set-sql-spec-column-name
+        set-sql-spec-type
+        set-sql-spec-modifiers
+    } sql-spec construct
+    dup normalize-spec ;
 
 : sql-type-hash ( -- assoc )
     H{
@@ -79,16 +81,62 @@ TUPLE: sql-spec slot-name column-name type modifiers ;
         { TIMESTAMP "timestamp" }
     } ;
 
-! HOOK: sql-type-hash db ( -- obj )
+TUPLE: no-sql-type ;
-! HOOK: >sql-type-string db ( obj -- str )
+: no-sql-type ( -- * ) T{ no-sql-type } throw ;
 
-: >sql-type-string ( obj -- str/f )
+TUPLE: no-sql-modifier ;
+: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ;
+
+: number>string* ( n/str -- str )
+    dup number? [ number>string ] when ;
+
+: maybe-remove-id ( specs -- obj )
+    [ native-id? not ] subset ;
+
+: remove-relations ( specs -- newcolumns )
+    [ relation? not ] subset ;
+
+: remove-id ( specs -- obj )
+    [ sql-spec-primary-key not ] subset ;
+
+! SQLite Types: http://www.sqlite.org/datatype3.html
+! NULL INTEGER REAL TEXT BLOB
+! PostgreSQL Types:
+! http://developer.postgresql.org/pgdocs/postgres/datatype.html
+
+
+
+HOOK: modifier-table db ( -- hash )
+HOOK: compound-modifier db ( str n -- hash )
+
+: lookup-modifier ( obj -- str )
     dup pair? [
-        first >sql-type-string
+        first2 >r lookup-modifier r> compound-modifier
     ] [
-        sql-type-hash at* [ drop "" ] unless
+        modifier-table at*
+        [ "unknown modifier" throw ] unless
     ] if ;
 
-: full-sql-type-string ( obj -- str )
+
-    [ >sql-type-string ] keep second
+HOOK: type-table db ( -- hash )
-    number>string " " swap 3append ;
+HOOK: create-type-table db ( -- hash )
+HOOK: compound-type db ( str n -- hash )
+
+: lookup-type* ( obj -- str )
+    dup pair? [
+        first lookup-type*
+    ] [
+        type-table at*
+        [ no-sql-type ] unless
+    ] if ;
+
+: lookup-create-type ( obj -- str )
+    dup pair? [
+        first2 >r lookup-create-type r> compound-type
+    ] [
+        dup create-type-table at*
+        [ nip ] [ drop lookup-type* ] if
+    ] if ;
+
+: lookup-type ( obj create? -- str )
+    [ lookup-create-type ] [ lookup-type* ] if ;