64 lines
2.0 KiB
Haskell
64 lines
2.0 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DefaultSignatures #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
module Database.PostgreSQL.Opium where
|
|
|
|
import Data.ByteString (ByteString)
|
|
import Data.Proxy (Proxy (Proxy))
|
|
import Database.PostgreSQL.LibPQ
|
|
(Result
|
|
, Row
|
|
)
|
|
import GHC.Generics (C, D, Generic, K1 (..), M1 (..), Meta (..), Rec0, Rep, S, to, (:*:) (..))
|
|
import GHC.TypeLits (KnownSymbol, symbolVal)
|
|
import Text.Printf (printf)
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Encoding
|
|
import qualified Database.PostgreSQL.LibPQ as LibPQ
|
|
|
|
class FromRow a where
|
|
fromRow :: Row -> Result -> IO (Maybe a)
|
|
default fromRow :: (Generic a, FromRow' (Rep a)) => Row -> Result -> IO (Maybe a)
|
|
fromRow row result = fmap to <$> fromRow' row result
|
|
|
|
class FromRow' f where
|
|
fromRow' :: Row -> Result -> IO (Maybe (f p))
|
|
|
|
instance FromRow' f => FromRow' (M1 D c f) where
|
|
fromRow' row result = fmap M1 <$> fromRow' row result
|
|
|
|
instance FromRow' f => FromRow' (M1 C c f) where
|
|
fromRow' row result = fmap M1 <$> fromRow' row result
|
|
|
|
instance (FromRow' f, FromRow' g) => FromRow' (f :*: g) where
|
|
fromRow' row result = do
|
|
y <- fromRow' row result
|
|
z <- fromRow' row result
|
|
pure $ (:*:) <$> y <*> z
|
|
|
|
instance (KnownSymbol nameSym, FromField t) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
|
|
fromRow' row result = do
|
|
mbColumn <- LibPQ.fnumber result name
|
|
case mbColumn of
|
|
Nothing -> pure Nothing
|
|
Just column -> do
|
|
mbField <- LibPQ.getvalue result row column
|
|
printf "%s: %s" (show name) (show mbField)
|
|
pure $ M1 . K1 <$> fromField mbField
|
|
where
|
|
name = Encoding.encodeUtf8 $ Text.pack $ symbolVal (Proxy :: Proxy nameSym)
|
|
|
|
class FromField a where
|
|
fromField :: Maybe ByteString -> Maybe a
|
|
|
|
instance FromField String where
|
|
fromField = fmap (Text.unpack . Encoding.decodeUtf8)
|
|
|
|
instance FromField Int where
|
|
fromField = fmap (read . Text.unpack . Encoding.decodeUtf8)
|