{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- |
-- Module      : Database.HDBC.Schema.SQLite3
-- Copyright   : 2013 Shohei Murayama, 2017-2019 Kei Hibiono
-- License     : BSD3
--
-- Maintainer  : shohei.murayama@gmail.com
-- Stability   : experimental
-- Portability : unknown
module Database.HDBC.Schema.SQLite3 (
  driverSQLite3
  ) where

import qualified Database.Relational.Schema.SQLite3.IndexInfo as IndexInfo
import qualified Database.Relational.Schema.SQLite3.IndexList as IndexList
import qualified Database.Relational.Schema.SQLite3.TableInfo as TableInfo

import Control.Applicative ((<|>))
import Control.Monad (guard)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT)
import Data.List (isPrefixOf, sort, sortBy)
import Data.Map (fromList)
import Database.HDBC (IConnection, SqlValue)
import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable ()
import Database.HDBC.Schema.Driver
  (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe,
   Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver)
import Database.Record (FromSql, ToSql)
import Database.Relational.Schema.SQLite3 (getType, indexInfoQuerySQL, indexListQuerySQL, normalizeColumn,
                                           normalizeType, notNull, tableInfoQuerySQL)
import Database.Relational.Schema.SQLite3.IndexInfo (IndexInfo)
import Database.Relational.Schema.SQLite3.IndexList (IndexList)
import Database.Relational.Schema.SQLite3.TableInfo (TableInfo)
import Database.Relational.Schema.SQLite3 (config)
import Language.Haskell.TH (TypeQ)


instance FromSql SqlValue TableInfo
instance ToSql SqlValue TableInfo

instance FromSql SqlValue IndexList
instance ToSql SqlValue IndexList

instance FromSql SqlValue IndexInfo
instance ToSql SqlValue IndexInfo

logPrefix :: String -> String
logPrefix :: String -> String
logPrefix = (String
"SQLite3: " forall a. [a] -> [a] -> [a]
++)

putLog :: LogChan -> String -> IO ()
putLog :: LogChan -> String -> IO ()
putLog LogChan
lchan = LogChan -> String -> IO ()
putVerbose LogChan
lchan forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix

compileError :: LogChan -> String -> MaybeT IO a
compileError :: forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan = forall a. LogChan -> String -> MaybeT IO a
failWith LogChan
lchan forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix

getPrimaryKey' :: IConnection conn
               => conn
               -> LogChan
               -> String
               -> String
               -> IO [String]
getPrimaryKey' :: forall conn.
IConnection conn =>
conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' conn
conn LogChan
lchan String
scm String
tbl = do
    [TableInfo]
tblinfo <- forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn (String -> String -> Query () TableInfo
tableInfoQuerySQL String
scm String
tbl) ()
    let primColumns :: [String]
primColumns = [ String -> String
normalizeColumn forall a b. (a -> b) -> a -> b
$ TableInfo -> String
TableInfo.name TableInfo
ti
                      | TableInfo
ti <- [TableInfo]
tblinfo, TableInfo -> Int16
TableInfo.pk TableInfo
ti forall a. Eq a => a -> a -> Bool
== Int16
1 ]
    if forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
primColumns forall a. Ord a => a -> a -> Bool
<= Int
1 then do
        LogChan -> String -> IO ()
putLog LogChan
lchan forall a b. (a -> b) -> a -> b
$ String
"getPrimaryKey: key=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
primColumns
        forall (m :: * -> *) a. Monad m => a -> m a
return [String]
primColumns
     else do
        [IndexList]
idxlist <- forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn (String -> String -> Query () IndexList
indexListQuerySQL String
scm String
tbl) ()
        let idxNames :: [String]
idxNames = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"sqlite_autoindex_")
                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map IndexList -> String
IndexList.name
                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((Int64
1 forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexList -> Int64
IndexList.unique) forall a b. (a -> b) -> a -> b
$ [IndexList]
idxlist
        [[IndexInfo]]
idxInfos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
ixn -> forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn (String -> String -> Query () IndexInfo
indexInfoQuerySQL String
scm String
ixn) ()) [String]
idxNames
        let isPrimaryKey :: [IndexInfo] -> Bool
isPrimaryKey = (forall a. Ord a => [a] -> [a]
sort [String]
primColumns forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String -> String
normalizeColumn forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexInfo -> String
IndexInfo.name)
        let idxInfo :: [IndexInfo]
idxInfo = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter [IndexInfo] -> Bool
isPrimaryKey forall a b. (a -> b) -> a -> b
$ [[IndexInfo]]
idxInfos
        let comp :: IndexInfo -> IndexInfo -> Ordering
comp IndexInfo
x IndexInfo
y = forall a. Ord a => a -> a -> Ordering
compare (IndexInfo -> Int64
IndexInfo.seqno IndexInfo
x) (IndexInfo -> Int64
IndexInfo.seqno IndexInfo
y)
        let primColumns' :: [String]
primColumns' = forall a b. (a -> b) -> [a] -> [b]
map IndexInfo -> String
IndexInfo.name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy IndexInfo -> IndexInfo -> Ordering
comp forall a b. (a -> b) -> a -> b
$ [IndexInfo]
idxInfo
        LogChan -> String -> IO ()
putLog LogChan
lchan forall a b. (a -> b) -> a -> b
$ String
"getPrimaryKey: keys=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
primColumns'
        forall (m :: * -> *) a. Monad m => a -> m a
return [String]
primColumns'

getColumns' :: IConnection conn
            => TypeMap
            -> conn
            -> LogChan
            -> String
            -> String
            -> IO ([(String, TypeQ)], [Int])
getColumns' :: forall conn.
IConnection conn =>
TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' TypeMap
tmap conn
conn LogChan
lchan String
scm String
tbl = forall b a. b -> (a -> b) -> MaybeT IO a -> IO b
maybeIO ([], []) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ do
    [TableInfo]
rows <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn (String -> String -> Query () TableInfo
tableInfoQuerySQL String
scm String
tbl) ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TableInfo]
rows) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan
      (String
"getFields: No columns found: schema = " forall a. [a] -> [a] -> [a]
++ String
scm forall a. [a] -> [a] -> [a]
++ String
", table = " forall a. [a] -> [a] -> [a]
++ String
tbl)
    let columnId :: TableInfo -> Int64
columnId = TableInfo -> Int64
TableInfo.cid
    let notNullIdxs :: [Int]
notNullIdxs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableInfo -> Int64
columnId) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter TableInfo -> Bool
notNull forall a b. (a -> b) -> a -> b
$ [TableInfo]
rows
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogChan -> String -> IO ()
putLog LogChan
lchan
        forall a b. (a -> b) -> a -> b
$ String
"getFields: num of columns = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TableInfo]
rows)
        forall a. [a] -> [a] -> [a]
++ String
", not null columns = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Int]
notNullIdxs
    let getType' :: TableInfo -> MaybeT IO (String, TypeQ)
getType' TableInfo
ti =
          forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe (Map String TypeQ -> TableInfo -> Maybe (String, TypeQ)
getType (forall k a. Ord k => [(k, a)] -> Map k a
fromList TypeMap
tmap) TableInfo
ti) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan
          (String
"Type mapping is not defined against SQLite3 type: "
           forall a. [a] -> [a] -> [a]
++ String -> String
normalizeType (TableInfo -> String
TableInfo.ctype TableInfo
ti))
    TypeMap
types <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TableInfo -> MaybeT IO (String, TypeQ)
getType' [TableInfo]
rows
    forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap
types, [Int]
notNullIdxs)

-- | Driver implementation
driverSQLite3 :: IConnection conn => Driver conn
driverSQLite3 :: forall conn. IConnection conn => Driver conn
driverSQLite3 =
    forall conn. IConnection conn => Driver conn
emptyDriver { getFieldsWithMap :: TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getFieldsWithMap = forall conn.
IConnection conn =>
TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' }
                { getPrimaryKey :: conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey    = forall conn.
IConnection conn =>
conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' }
                { driverConfig :: Config
driverConfig     = Config
config }