add parsing for postgresql errors and some unit tests

basis/db/errors/errors.factor

@@ -1,18 +1,24 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ;
+USING: accessors kernel ;
 IN: db.errors
 
 ERROR: db-error ;
-ERROR: sql-error ;
+ERROR: sql-error location ;
 
-ERROR: table-exists ;
 ERROR: bad-schema ;
 
-ERROR: sql-syntax-error error ;
+ERROR: sql-table-exists < sql-error table ;
+: <sql-table-exists> ( table -- error )
+    \ sql-table-exists new
+        swap >>table ;
 
-ERROR: sql-table-exists table ;
+ERROR: sql-table-missing < sql-error table ;
-C: <sql-table-exists> sql-table-exists
+: <sql-table-missing> ( table -- error )
+    \ sql-table-missing new
+        swap >>table ;
 
-ERROR: sql-table-missing table ;
+ERROR: sql-syntax-error < sql-error message ;
-C: <sql-table-missing> sql-table-missing
+: <sql-syntax-error> ( message -- error )
+    \ sql-syntax-error new
+        swap >>message ;

basis/db/errors/postgresql/postgresql-tests.factor

@@ -1,4 +1,32 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test db.errors.postgresql ;
+USING: accessors combinators.short-circuit db db.errors
+db.errors.postgresql db.postgresql io.files.unique kernel namespaces
+tools.test db.tester ;
 IN: db.errors.postgresql.tests
+
+postgresql-test-db [
+
+    [ "drop table foo;" sql-command ] ignore-errors
+    [ "drop table ship;" sql-command ] ignore-errors
+
+    [
+        "insert into foo (id) values('1');" sql-command
+    ] [
+        { [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
+    ] must-fail-with
+
+    [
+        "create table ship(id integer);" sql-command
+        "create table ship(id integer);" sql-command
+    ] [
+        { [ sql-table-exists? ] [ table>> "ship" = ] } 1&&
+    ] must-fail-with
+    
+    [
+        "create table foo(id) lol;" sql-command
+    ] [
+        sql-syntax-error?
+    ] must-fail-with
+
+] with-db

basis/db/errors/postgresql/postgresql.factor

@@ -1,4 +1,60 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: ;
+USING: kernel db.errors peg.ebnf strings sequences math
+combinators.short-circuit accessors math.parser ;
 IN: db.errors.postgresql
+
+! ERROR:  relation "foo" does not exist
+
+: quote? ( ch -- ? ) "'\"" member? ;
+
+: quoted? ( str -- ? )
+    {
+        [ length 1 > ]
+        [ first quote? ]
+        [ [ first ] [ peek ] bi = ]
+    } 1&& ;
+
+: unquote ( str -- newstr )
+    dup quoted? [ but-last-slice rest-slice >string ] when ;
+
+
+EBNF: parse-postgresql-sql-error
+
+Error = "ERROR:" [ ]+
+
+TableError =
+    Error "relation " (!(" already exists").)+:table " already exists"
+        => [[ table >string unquote <sql-table-exists> ]]
+    | Error "relation " (!(" does not exist").)+:table " does not exist"
+        => [[ table >string unquote <sql-table-missing> ]]
+
+SyntaxError =
+    Error "syntax error at end of input":error
+        => [[ error >string <sql-syntax-error> ]]
+    | Error "syntax error at or near " .+:syntaxerror
+        => [[ syntaxerror >string unquote <sql-syntax-error> ]]
+
+PostgresqlSqlError = (TableError | SyntaxError) 
+
+;EBNF
+
+
+ERROR: parse-postgresql-location column line text ;
+C: <parse-postgresql-location> parse-postgresql-location
+
+EBNF: parse-postgresql-line-error
+
+Line = "LINE " [0-9]+:line ": " .+:sql
+    => [[ f line >string string>number sql >string <parse-postgresql-location> ]] 
+
+;EBNF
+
+:: set-caret-position ( error caret-line -- error )
+    caret-line length
+    error line>> number>string length "LINE : " length +
+    - [ error ] dip >>column ;
+
+: postgresql-location ( line column -- obj )
+    [ parse-postgresql-line-error ] dip
+    set-caret-position ;

basis/db/postgresql/postgresql-tests.factor

@@ -1,15 +1,8 @@
 USING: kernel db.postgresql alien continuations io classes
 prettyprint sequences namespaces tools.test db db.private
-db.tuples db.types unicode.case accessors system ;
+db.tuples db.types unicode.case accessors system db.tester ;
 IN: db.postgresql.tests
 
-: postgresql-test-db ( -- postgresql-db )
-    <postgresql-db>
-        "localhost" >>host
-        "postgres" >>username
-        "thepasswordistrust" >>password
-        "factor-test" >>database ;
-
 os windows? cpu x86.64? and [
     [ ] [ postgresql-test-db [ ] with-db ] unit-test
 

basis/db/postgresql/postgresql.factor

@@ -6,7 +6,7 @@ sequences debugger db db.postgresql.lib db.postgresql.ffi
 db.tuples db.types tools.annotations math.ranges
 combinators classes locals words tools.walker db.private
 nmake accessors random db.queries destructors db.tuples.private
-db.postgresql ;
+db.postgresql db.errors.postgresql splitting ;
 IN: db.postgresql
 
 TUPLE: postgresql-db host port pgopts pgtty database username password ;
@@ -282,4 +282,12 @@ M: postgresql-db-connection compound ( string object -- string' )
     } case ;
 
 M: postgresql-db-connection parse-db-error
-    ;
+    "\n" split dup length {
+        { 1 [ first parse-postgresql-sql-error ] }
+        { 3 [
+                first3
+                [ parse-postgresql-sql-error ] 2dip
+                postgresql-location >>location
+        ] }
+    } case ;
+

basis/db/sqlite/lib/lib.factor

@@ -11,12 +11,17 @@ IN: db.sqlite.lib
 ERROR: sqlite-error < db-error n string ;
 ERROR: sqlite-sql-error < sql-error n string ;
 
+: <sqlite-sql-error> ( n string -- error )
+    \ sqlite-sql-error new
+        swap >>string
+        swap >>n ;
+
 : throw-sqlite-error ( n -- * )
     dup sqlite-error-messages nth sqlite-error ;
 
 : sqlite-statement-error ( -- * )
     SQLITE_ERROR
-    db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
+    db-connection get handle>> sqlite3_errmsg <sqlite-sql-error> throw ;
 
 : sqlite-check-result ( n -- )
     {

basis/db/tester/tester.factor

@@ -2,9 +2,42 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: concurrency.combinators db.pools db.sqlite db.tuples
 db.types kernel math random threads tools.test db sequences
-io prettyprint ;
+io prettyprint db.postgresql db.sqlite accessors io.files.temp
+namespaces fry system ;
 IN: db.tester
 
+: postgresql-test-db ( -- postgresql-db )
+    <postgresql-db>
+        "localhost" >>host
+        "postgres" >>username
+        "thepasswordistrust" >>password
+        "factor-test" >>database ;
+
+: sqlite-test-db ( -- sqlite-db )
+    "tuples-test.db" temp-file <sqlite-db> ;
+
+
+! These words leak resources, but are useful for interactivel testing
+: set-sqlite-db ( -- )
+    sqlite-db db-open db-connection set ;
+
+: set-postgresql-db ( -- )
+    postgresql-db db-open db-connection set ;
+
+
+: test-sqlite ( quot -- )
+    '[
+        [ ] [ sqlite-test-db _ with-db ] unit-test
+    ] call ; inline
+
+: test-postgresql ( quot -- )
+    '[
+        os windows? cpu x86.64? and [
+            [ ] [ postgresql-test-db _ with-db ] unit-test
+        ] unless
+    ] call ; inline
+
+
 TUPLE: test-1 id a b c ;
 
 test-1 "TEST1" {
@@ -23,9 +56,6 @@ test-2 "TEST2" {
    { "z" "Z" { VARCHAR 256 } +not-null+ }
 } define-persistent
 
-: sqlite-test-db ( -- db ) "test.db" <sqlite-db> ;
-: test-db ( -- db ) "test.db" <sqlite-db> ;
-
 : db-tester ( test-db -- )
     [
         [

basis/db/tuples/tuples-tests.factor

@@ -4,40 +4,10 @@ USING: io.files io.files.temp kernel tools.test db db.tuples classes
 db.types continuations namespaces math math.ranges
 prettyprint calendar sequences db.sqlite math.intervals
 db.postgresql accessors random math.bitwise system
-math.ranges strings urls fry db.tuples.private db.private ;
+math.ranges strings urls fry db.tuples.private db.private
+db.tester ;
 IN: db.tuples.tests
 
-: sqlite-db ( -- sqlite-db )
-    "tuples-test.db" temp-file <sqlite-db> ;
-
-: test-sqlite ( quot -- )
-    '[
-        [ ] [
-            "tuples-test.db" temp-file <sqlite-db> _ with-db
-        ] unit-test
-    ] call ; inline
-
-: postgresql-db ( -- postgresql-db )
-    <postgresql-db>
-        "localhost" >>host
-        "postgres" >>username
-        "thepasswordistrust" >>password
-        "factor-test" >>database ;
-
-: test-postgresql ( quot -- )
-    '[
-        os windows? cpu x86.64? and [
-            [ ] [ postgresql-db _ with-db ] unit-test
-        ] unless
-    ] call ; inline
-
-! These words leak resources, but are useful for interactivel testing 
-: sqlite-test-db ( -- )
-    sqlite-db db-open db-connection set ;
-
-: postgresql-test-db ( -- )
-    postgresql-db db-open db-connection set ;
-
 TUPLE: person the-id the-name the-number the-real
 ts date time blob factor-blob url ;