    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    module Database.TokyoCabinet
        (
        -- $doc
          TCM
        , runTCM
        , OpenMode(..)
        , TCDB(..)
        , H.HDB
        , F.FDB
        , T.TDB
        , BDB
        -- * Error Code
        , E.ECODE(..)
        , E.errmsg
        ) where

    import Control.Monad.Trans (MonadIO)

    import Database.TokyoCabinet.Storable
    import Database.TokyoCabinet.Sequence
    import Database.TokyoCabinet.FDB.Key (ID, toID)
    import qualified Database.TokyoCabinet.HDB as H
    import qualified Database.TokyoCabinet.FDB as F
    import qualified Database.TokyoCabinet.TDB as T
    import qualified Database.TokyoCabinet.BDB as B
    import qualified Database.TokyoCabinet.BDB.Cursor as C
    import qualified Database.TokyoCabinet.Error as E

    import Data.Int
    import Data.Word

    -- $doc
    -- Basic Usage (sample code)
    --
    -- @
    --    import Database.TokyoCabinet
    --    import Data.ByteString.Char8
    -- @
    --
    -- @
    --    putsample :: String -> [(ByteString, ByteString)] -> TCM Bool
    --    putsample file kv =
    --        do tc <- new :: TCM HDB -- alternatively you can use BDB or FDB
    --           open tc file [OWRITER, OCREAT]
    --           mapM (uncurry $ put tc) kv
    --           close tc
    -- @
    --
    -- @
    --    getsample :: String -> ByteString -> TCM (Maybe ByteString)
    --    getsample file key =
    --        do tc <- new :: TCM HDB -- alternatively you can use BDB or FDB
    --           open tc file [OREADER]
    --           val <- get tc key
    --           close tc
    --           return val
    -- @
    --
    -- @
    --    main = runTCM (do putsample \"foo.tch\" [(pack \"foo\", pack \"bar\")]
    --                      getsample \"foo.tch\" (pack \"foo\")) >>=
    --           maybe (return ()) (putStrLn . show)
    -- @
    --

    -- | Tokyo Cabinet related computation. Wrap of IO.
    newtype TCM a =
        TCM { -- | Unwrap TCM.
              runTCM :: IO a
        } deriving (Monad, MonadIO)

    -- | Represent open mode for `open' function.
    data OpenMode = OREADER |
                    OWRITER |
                    OCREAT  |
                    OTRUNC  |
                    ONOLCK  |
                    OLCKNB
                    deriving (Eq, Ord, Show)

    -- | Type class that abstract Tokyo Cabinet database.
    class TCDB a where
        -- | Create a database object.
        new       :: TCM a

        -- | Free object resource forcibly.
        delete    :: a -> TCM ()

        -- | Open a database file.
        open      :: a          -- ^ database object
                  -> String     -- ^ path to database file
                  -> [OpenMode] -- ^ open mode
                  -> TCM Bool   -- ^ if successful, the return value is True

        -- | Close the database file. If successful, the return value is True
        close     :: a -> TCM Bool

        -- | Store a record.
        put       :: (Storable k, Storable v) =>
                     a -- ^ database object
                  -> k -- ^ key
                  -> v -- ^ value
                  -> TCM Bool -- ^ if successful, the return value is True

        -- | Store a new recoed. If a record with the same key exists
        -- in the database, this function has no effect.
        putkeep   :: (Storable k, Storable v) =>
                     a -- ^ database object
                  -> k -- ^ key
                  -> v -- ^ value
                  -> TCM Bool -- ^ if successful, the return value is True

        -- | Concatenate a value at the end of the existing record.
        putcat    :: (Storable k, Storable v) =>
                     a -- ^ database object
                  -> k -- ^ key
                  -> v -- ^ value
                  -> TCM Bool -- ^ if successful, the return value is True

        -- | Retrieve a record.
        get       :: (Storable k, Storable v) =>
                     a -- ^ database object
                  -> k -- ^ key
                  -> TCM (Maybe v) -- ^ If successful, the return value is the
                                   -- value of the corresponding record wrapped
                                   -- by `Just', else, Nothing is returned.

        -- | Remove a record.
        out       :: (Storable k) =>
                     a -- ^ database object
                  -> k -- ^ key
                  -> TCM Bool -- ^ if successful, the return value is True

        -- | Get the size of the value of a record.
        vsiz      :: (Storable k) =>
                     a -- ^ database object
                  -> k -- ^ key
                  -> TCM (Maybe Int) -- ^ If successful, the return value
                                     -- is the size of the value of the
                                     -- corresponding record wrapped by
                                     -- `Just', else, it is Nothing.

        -- | Initialize the iterator. If successful, the return value is True.
        iterinit  :: a -> TCM Bool

        -- | Get the next key of the iterator.  If successful, the return
        -- value is the next key wrapped by `Just', else, it is Nothing.
        iternext  :: (Storable v) => a -> TCM (Maybe v)

        -- | Get forward matching keys.
        fwmkeys   :: (Storable k, Storable v, Sequence q) =>
                     a   -- ^ database object
                  -> k   -- ^ search string
                  -> Int -- ^ the maximum number of keys to be fetched
                  -> TCM (q v) -- ^ result keys

        -- | Add an integer to a record.
        addint    :: (Storable k) =>
                     a -- ^ database object
                  -> k -- ^ key
                  -> Int -- ^ the addtional value
                  -> TCM (Maybe Int) -- ^ If the corresponding record
                                     -- exists, the value is treated as an
                                     -- integer and is added to. If no
                                     -- record corresponds, a new record
                                     -- of the additional value is stored.

        -- | Add a real number to a record.
        adddouble :: (Storable k) =>
                     a -- ^ database object
                  -> k -- ^ key
                  -> Double -- ^ the additional value
                  -> TCM (Maybe Double) -- ^ If the corresponding record
                                        -- exists, the value is treated as
                                        -- a real number and is added
                                        -- to. If no record corresponds, a
                                        -- new record of the additional
                                        -- value is stored.

        -- | Synchronize updated contents with the file and the device.
        -- If successful, the return value is True.
        sync      :: a -> TCM Bool

        -- | Remove all records. If successful, the return value is True.
        vanish    :: a -> TCM Bool

        -- | Copy the database file.
        copy      :: a        -- ^ database object
                  -> String   -- ^ path of the destination file
                  -> TCM Bool -- ^ If successful, the return value is True.

        -- | Get the path of the database file.
        path      :: a -> TCM (Maybe String)

        -- | Get the number of records.
        rnum      :: a -> TCM Word64

        -- | Get the size of the database file.
        size      :: a -> TCM Word64

        -- | Get the last happened error code.
        ecode     :: a -> TCM E.ECODE

        -- | Get the default extension for specified database object.
        defaultExtension :: a -> String

    openModeToHOpenMode :: OpenMode -> H.OpenMode
    openModeToHOpenMode OREADER = H.OREADER
    openModeToHOpenMode OWRITER = H.OWRITER
    openModeToHOpenMode OCREAT  = H.OCREAT
    openModeToHOpenMode OTRUNC  = H.OTRUNC
    openModeToHOpenMode ONOLCK  = H.ONOLCK
    openModeToHOpenMode OLCKNB  = H.OLCKNB

    lift :: (a -> IO b) -> a -> TCM b
    lift = (TCM .)

    lift2 :: (a -> b -> IO c) -> a -> b -> TCM c
    lift2 f x y = TCM $ f x y

    lift3 :: (a -> b -> c -> IO d) -> a -> b -> c -> TCM d
    lift3 f x y z = TCM $ f x y z

    instance TCDB H.HDB where
        new               = TCM   H.new
        delete            = lift  H.delete
        open tc name mode = TCM $ H.open tc name (map openModeToHOpenMode mode)
        close             = lift  H.close
        put               = lift3 H.put
        putkeep           = lift3 H.putkeep
        putcat            = lift3 H.putcat
        get               = lift2 H.get
        out               = lift2 H.out
        vsiz              = lift2 H.vsiz
        iterinit          = lift  H.iterinit
        iternext          = lift  H.iternext
        fwmkeys           = lift3 H.fwmkeys
        addint            = lift3 H.addint
        adddouble         = lift3 H.adddouble
        sync              = lift  H.sync
        vanish            = lift  H.vanish
        copy              = lift2 H.copy
        path              = lift  H.path
        rnum              = lift  H.rnum
        size              = lift  H.fsiz
        ecode             = lift  H.ecode
        defaultExtension  = const ".tch"

    openModeToBOpenMode :: OpenMode -> B.OpenMode
    openModeToBOpenMode OREADER = B.OREADER
    openModeToBOpenMode OWRITER = B.OWRITER
    openModeToBOpenMode OCREAT  = B.OCREAT
    openModeToBOpenMode OTRUNC  = B.OTRUNC
    openModeToBOpenMode ONOLCK  = B.ONOLCK
    openModeToBOpenMode OLCKNB  = B.OLCKNB

    data BDB = BDB { unTCBDB    :: B.BDB
                   , unTCBDBCUR :: C.BDBCUR }

    liftB :: (B.BDB -> IO a) -> BDB -> TCM a
    liftB f x = TCM $ f (unTCBDB x)

    liftB2 :: (B.BDB -> a -> IO b) -> BDB -> a -> TCM b
    liftB2 f x y = TCM $ f (unTCBDB x) y

    liftB3 :: (B.BDB -> a -> b -> IO c) -> BDB -> a -> b -> TCM c
    liftB3 f x y z = TCM $ f (unTCBDB x) y z

    instance TCDB BDB where
        new               = TCM $ do bdb <- B.new
                                     cur <- C.new bdb
                                     return $ BDB bdb cur
        delete            = liftB  B.delete
        open tc name mode = TCM $  B.open (unTCBDB tc) name
                                       (map openModeToBOpenMode mode)
        close             = liftB  B.close
        put               = liftB3 B.put
        putkeep           = liftB3 B.putkeep
        putcat            = liftB3 B.putcat
        get               = liftB2 B.get
        out               = liftB2 B.out
        vsiz              = liftB2 B.vsiz
        iterinit bdb      = TCM $ C.first (unTCBDBCUR bdb)
        iternext bdb      = TCM $ do k <- C.key (unTCBDBCUR bdb)
                                     C.next (unTCBDBCUR bdb)
                                     return k
        fwmkeys           = liftB3 B.fwmkeys
        addint            = liftB3 B.addint
        adddouble         = liftB3 B.adddouble
        sync              = liftB  B.sync
        vanish            = liftB  B.vanish
        copy              = liftB2 B.copy
        path              = liftB  B.path
        rnum              = liftB  B.rnum
        size              = liftB  B.fsiz
        ecode             = liftB  B.ecode
        defaultExtension  = const ".tcb"

    instance TCDB B.BDB where
        new               = TCM   B.new
        delete            = lift  B.delete
        open tc name mode = TCM $ B.open tc name (map openModeToBOpenMode mode)
        close             = lift  B.close
        put               = lift3 B.put
        putkeep           = lift3 B.putkeep
        putcat            = lift3 B.putcat
        get               = lift2 B.get
        out               = lift2 B.out
        vsiz              = lift2 B.vsiz
        iterinit          = undefined
        iternext          = undefined
        fwmkeys           = lift3 B.fwmkeys
        addint            = lift3 B.addint
        adddouble         = lift3 B.adddouble
        sync              = lift  B.sync
        vanish            = lift  B.vanish
        copy              = lift2 B.copy
        path              = lift  B.path
        rnum              = lift  B.rnum
        size              = lift  B.fsiz
        ecode             = lift  B.ecode
        defaultExtension  = const ".tcb"

    openModeToFOpenMode :: OpenMode -> F.OpenMode
    openModeToFOpenMode OREADER = F.OREADER
    openModeToFOpenMode OWRITER = F.OWRITER
    openModeToFOpenMode OCREAT  = F.OCREAT
    openModeToFOpenMode OTRUNC  = F.OTRUNC
    openModeToFOpenMode ONOLCK  = F.ONOLCK
    openModeToFOpenMode OLCKNB  = F.OLCKNB

    storableToKey :: (Storable a) => a -> ID
    storableToKey = toID . toInt64

    liftF2 :: (Storable b) => (a -> ID -> IO c) -> a -> b -> TCM c
    liftF2 f x y = TCM $ f x (storableToKey y)

    liftF3 :: (Storable b) => (a -> ID -> c -> IO d) -> a -> b -> c -> TCM d
    liftF3 f x y z = TCM $ f x (storableToKey y) z

    keyToStorable :: (Storable a) => String -> a
    keyToStorable = fromString

    instance TCDB F.FDB where
        new               = TCM    F.new
        delete            = lift   F.delete
        open tc name mode = TCM $  F.open tc name (map openModeToFOpenMode mode)
        close             = lift   F.close
        put               = liftF3 F.put
        putkeep           = liftF3 F.putkeep
        putcat            = liftF3 F.putcat
        get               = liftF2 F.get
        out               = liftF2 F.out
        vsiz              = liftF2 F.vsiz
        iterinit          = lift   F.iterinit
        iternext tc       = TCM    $ do key <- F.iternext tc
                                        case key of
                                          Nothing -> return Nothing
                                          Just x  -> return $ Just (keyToStorable x)
        fwmkeys           = lift3  F.fwmkeys
        addint            = liftF3 F.addint
        adddouble         = liftF3 F.adddouble
        sync              = lift   F.sync
        vanish            = lift   F.vanish
        copy              = lift2  F.copy
        path              = lift   F.path
        rnum              = lift   F.rnum
        size              = lift   F.fsiz
        ecode             = lift   F.ecode
        defaultExtension  = const ".tcf"

    openModeToTOpenMode :: OpenMode -> T.OpenMode
    openModeToTOpenMode OREADER = T.OREADER
    openModeToTOpenMode OWRITER = T.OWRITER
    openModeToTOpenMode OCREAT  = T.OCREAT
    openModeToTOpenMode OTRUNC  = T.OTRUNC
    openModeToTOpenMode ONOLCK  = T.ONOLCK
    openModeToTOpenMode OLCKNB  = T.OLCKNB

    instance TCDB T.TDB where
        new               = TCM   T.new
        delete            = lift  T.delete
        open tc name mode = TCM $ T.open tc name (map openModeToTOpenMode mode)
        close             = lift  T.close
        put               = lift3 T.put'
        putkeep           = lift3 T.putkeep'
        putcat            = lift3 T.putcat'
        get               = lift2 T.get'
        out               = lift2 T.out
        vsiz              = lift2 T.vsiz
        iterinit          = lift  T.iterinit
        iternext          = lift  T.iternext
        fwmkeys           = lift3 T.fwmkeys
        addint            = lift3 T.addint
        adddouble         = lift3 T.adddouble
        sync              = lift  T.sync
        vanish            = lift  T.vanish
        copy              = lift2 T.copy
        path              = lift  T.path
        rnum              = lift  T.rnum
        size              = lift  T.fsiz
        ecode             = lift  T.ecode
        defaultExtension  = const ".tct"