factor/extra/db/sqlite/sqlite.factor

! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators math.intervals
io namespaces.lib accessors vectors math.ranges random
math.bitfields.lib ;
USE: tools.walker
IN: db.sqlite

TUPLE: sqlite-db < db path ;

M: sqlite-db make-db* ( path db -- db )
    swap >>path ;

M: sqlite-db db-open ( db -- db )
    [ path>> sqlite-open ] [ swap >>handle ] bi ;

M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;

TUPLE: sqlite-statement < statement ;

TUPLE: sqlite-result-set < result-set has-more? ;

M: sqlite-db <simple-statement> ( str in out -- obj )
    <prepared-statement> ;

M: sqlite-db <prepared-statement> ( str in out -- obj )
    sqlite-statement construct-statement ;

: sqlite-maybe-prepare ( statement -- statement )
    dup handle>> [
        db get handle>> over sql>> sqlite-prepare
        >>handle
    ] unless ;

M: sqlite-statement dispose ( statement -- )
    handle>>
    [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;

M: sqlite-result-set dispose ( result-set -- )
    f >>handle drop ;

: reset-statement ( statement -- )
    sqlite-maybe-prepare handle>> sqlite-reset ;

: reset-bindings ( statement -- )
    sqlite-maybe-prepare
    handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;

M: sqlite-statement low-level-bind ( statement -- )
    [ statement-bind-params ] [ statement-handle ] bi
    swap [ first3 sqlite-bind-type ] with each ;

M: sqlite-statement bind-statement* ( statement -- )
    sqlite-maybe-prepare
    dup statement-bound? [ dup reset-bindings ] when
    low-level-bind ;

GENERIC: sqlite-bind-conversion ( tuple obj -- array )

M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
    [ column-name>> ":" prepend ]
    [ slot-name>> rot get-slot-named ]
    [ type>> ] tri 3array ;

M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
    nip [ key>> ] [ value>> ] [ type>> ] tri 3array ;

M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
    nip [ key>> ] [ quot>> call ] [ type>> ] tri 3array ;

M: sqlite-statement bind-tuple ( tuple statement -- )
    [
        in-params>> [ sqlite-bind-conversion ] with map
    ] keep bind-statement ;

: last-insert-id ( -- id )
    db get db-handle sqlite3_last_insert_rowid
    dup zero? [ "last-id failed" throw ] when ;

M: sqlite-db insert-tuple* ( tuple statement -- )
    execute-statement last-insert-id swap set-primary-key ;

M: sqlite-result-set #columns ( result-set -- n )
    handle>> sqlite-#columns ;

M: sqlite-result-set row-column ( result-set n -- obj )
    [ handle>> ] [ sqlite-column ] bi* ;

M: sqlite-result-set row-column-typed ( result-set n -- obj )
    dup pick out-params>> nth type>>
    >r >r handle>> r> r> sqlite-column-typed ;

M: sqlite-result-set advance-row ( result-set -- )
    dup handle>> sqlite-next >>has-more? drop ;

M: sqlite-result-set more-rows? ( result-set -- ? )
    has-more?>> ;

M: sqlite-statement query-results ( query -- result-set )
    sqlite-maybe-prepare
    dup handle>> sqlite-result-set construct-result-set
    dup advance-row ;

M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ;
M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;

: maybe-make-retryable ( statement -- statement )
    dup in-params>> [ generator-bind? ] contains? [
        make-retryable
    ] when ;

: sqlite-make ( class quot -- )
    >r sql-props r>
    [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
    <simple-statement> maybe-make-retryable ;

M: sqlite-db create-sql-statement ( class -- statement )
    [
        "create table " 0% 0%
        "(" 0% [ ", " 0% ] [
            dup column-name>> 0%
            " " 0%
            dup type>> lookup-create-type 0%
            modifiers 0%
        ] interleave ");" 0%
    ] sqlite-make dup sql>> . ;

M: sqlite-db drop-sql-statement ( class -- statement )
    [ "drop table " 0% 0% ";" 0% drop ] sqlite-make ;

M: sqlite-db <insert-native-statement> ( tuple -- statement )
    [
        "insert into " 0% 0%
        "(" 0%
        maybe-remove-id
        dup [ ", " 0% ] [ column-name>> 0% ] interleave
        ") values(" 0%
        [ ", " 0% ] [
            dup type>> +random-id+ = [
                dup modifiers>> find-random-generator
                [
                    [
                        column-name>> ":" prepend
                        dup 0% random-id-quot
                    ] with-random
                ] curry
                [ type>> ] bi <generator-bind> 1,
            ] [
                bind%
            ] if
        ] interleave
        ");" 0%
    ] sqlite-make ;

M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
    <insert-native-statement> ;

M: sqlite-db bind# ( spec obj -- )
    >r
    [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
    [ type>> ] bi
    r> <literal-bind> 1, ;

M: sqlite-db bind% ( spec -- )
    dup 1, column-name>> ":" prepend 0% ;

: where-primary-key% ( specs -- )
    " where " 0%
    find-primary-key dup column-name>> 0% " = " 0% bind% ;

GENERIC: where ( specs obj -- )

: interval-comparison ( ? str -- str )
    "from" = " >" " <" ? swap [ "= " append ] when ;

: where-interval ( spec obj from/to -- )
    pick column-name>> 0%
    >r first2 r> interval-comparison 0%
    bind# ;

: in-parens ( quot -- )
    "(" 0% call ")" 0% ; inline

M: interval where ( spec obj -- )
    [
        [ from>> "from" where-interval " and " 0% ]
        [ to>> "to" where-interval ] 2bi
    ] in-parens ;

M: sequence where ( spec obj -- )
    [
        [ " or " 0% ] [ dupd where ] interleave drop
    ] in-parens ;

: object-where ( spec obj -- )
    over column-name>> 0% " = " 0% bind# ;

M: object where ( spec obj -- ) object-where ;

M: integer where ( spec obj -- ) object-where ;

M: string where ( spec obj -- ) object-where ;

: where-clause ( tuple specs -- )
    " where " 0% [
        " and " 0%
    ] [
        2dup slot-name>> swap get-slot-named where
    ] interleave drop ;

M: sqlite-db <update-tuple-statement> ( class -- statement )
    [
        "update " 0%
        0%
        " set " 0%
        dup remove-id
        [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
        where-primary-key%
    ] sqlite-make ;

M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
    [
        "delete from " 0% 0%
        " where " 0%
        find-primary-key
        dup column-name>> 0% " = " 0% bind%
    ] sqlite-make ;

M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
    [
        "select " 0%
        over [ ", " 0% ]
        [ dup column-name>> 0% 2, ] interleave

        " from " 0% 0%
        dupd
        [ slot-name>> swap get-slot-named ] with subset
        dup empty? [ 2drop ] [ where-clause ] if ";" 0%
    ] sqlite-make ;

M: sqlite-db random-id-quot ( -- quot )
    [ 64 [ 2^ random ] keep 1 - set-bit ] ;

M: sqlite-db persistent-table ( -- assoc )
    H{
        { +native-id+ { "integer primary key" "integer primary key" f } }
        { +assigned-id+ { f f "primary key" } }
        { +random-id+ { "integer primary key" "integer primary key" f } }
        { INTEGER { "integer" "integer" "primary key" } }
        { BIG-INTEGER { "bigint" "bigint" } }
        { SIGNED-BIG-INTEGER { "bigint" "bigint" } }
        { UNSIGNED-BIG-INTEGER { "bigint" "bigint" } }
        { TEXT { "text" "text" } }
        { VARCHAR { "text" "text" } }
        { DATE { "date" "date" } }
        { TIME { "time" "time" } }
        { DATETIME { "datetime" "datetime" } }
        { TIMESTAMP { "timestamp" "timestamp" } }
        { DOUBLE { "real" "real" } }
        { BLOB { "blob" "blob" } }
        { FACTOR-BLOB { "blob" "blob" } }
        { +autoincrement+ { f f "autoincrement" } }
        { +unique+ { f f "unique" } }
        { +default+ { f f "default" } }
        { +null+ { f f "null" } }
        { +not-null+ { f f "not null" } }
        { system-random-generator { f f f } }
        { secure-random-generator { f f f } }
        { random-generator { f f f } }
    } ;

M: sqlite-db compound ( str seq -- str' )
    over {
        { "default" [ first number>string join-space ] }
        [ 2drop ] 
    } case ;