module Database.Sql.Simple.Internal where
import GHC.Exts (Constraint)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Applicative
import qualified Data.Text as T
import Data.Proxy
import Data.Typeable
import Data.String
import qualified Data.Map.Strict as M
data Query = Query T.Text (M.Map TypeRep T.Text)
deriving (Show, Eq)
newtype Sql (l :: [*]) a = Sql { unSql :: IO a }
deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadBase IO)
instance MonadBaseControl IO (Sql l) where
newtype StM (Sql l) a = StMSql { unStMSql :: StM IO a }
liftBaseWith f = Sql $
liftBaseWith (\run -> f $ liftM StMSql . run . unSql)
restoreM = Sql . restoreM . unStMSql
instance IsString Query where
fromString s = Query (T.pack s) M.empty
getQuery :: TypeRep -> Query -> T.Text
getQuery t (Query d h) = maybe d id $ M.lookup t h
newtype Only a = Only { fromOnly :: a }
data h :. t = h :. t
infixr 3 :.
class Elem a (as :: [*])
instance Elem a (a ': as)
instance Elem a as => Elem a (a' ': as)
withConnection :: (Backend b, Elem b bs) => ConnectInfo b -> (b -> Sql bs a) -> IO a
withConnection i f = bracket (connect i) close (unSql . f)
sql :: proxy bs -> Sql bs a -> Sql bs a
sql _ m = m
class Typeable b => Backend b where
data ConnectInfo b
type ToRow b :: * -> Constraint
type FromRow b :: * -> Constraint
connect :: ConnectInfo b -> IO b
close :: b -> IO ()
execute :: ToRow b q => b -> Query -> q -> Sql c ()
execute_ :: b -> Query -> Sql c ()
query :: (FromRow b r, ToRow b q) => b -> Query -> q -> Sql c [r]
query_ :: FromRow b r => b -> Query -> Sql c [r]
fold :: (FromRow b r, ToRow b q) => b -> Query -> q -> a -> (a -> r -> IO a) -> IO a
fold_ :: FromRow b r => b -> Query -> a -> (a -> r -> IO a) -> IO a
forEach :: (FromRow b r, ToRow b q) => b -> Query -> q -> (r -> IO ()) -> IO ()
forEach c q qs = fold c q qs () . const
forEach_ :: FromRow b r => b -> Query -> (r -> IO ()) -> IO ()
forEach_ c q = fold_ c q () . const
class Backend b => Transaction b where
begin :: b -> Sql c ()
commit :: b -> Sql c ()
rollback :: b -> Sql c ()
withTransaction :: b -> Sql c a -> Sql c a
withTransaction c action = mask $ \restore -> do
begin c
r <- restore action `onException` rollback c
commit c
return r
type family (a :: [k]) ++ (b :: [k]) :: [k]
type instance '[] ++ bs = bs
type instance (a ': as) ++ bs = a ': as ++ bs
(+:+) :: Proxy a -> Proxy b -> Proxy (a ++ b)
_ +:+ _ = Proxy
specify :: Backend b => proxy ((b :: *) ': '[]) -> T.Text -> Query -> Query
specify p q (Query t h) = Query t (M.insert (headt p) q h)
where
headt :: forall proxy a as. Typeable a => proxy ((a :: *) ': as) -> TypeRep
headt _ = typeOf (undefined :: a)