{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module Database.PostgreSQL.Opium
  ( FromField (..)
  , FromRow (..)
  , fetch_
  )
  where

import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.ByteString (ByteString)
import Data.Proxy (Proxy (Proxy))
import Database.PostgreSQL.LibPQ
  ( Connection
  , 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

import Database.PostgreSQL.Opium.FromField (FromField (..))

fetch_ :: FromRow a => Connection -> ByteString -> IO (Maybe [a])
fetch_ conn query = runMaybeT $ do
  result <- MaybeT $ LibPQ.execParams conn query [] LibPQ.Text
  MaybeT $ fetchResult result

fetchResult :: FromRow a => Result -> IO (Maybe [a])
fetchResult result = do
  nRows <- LibPQ.ntuples result
  runMaybeT $ mapM (MaybeT . flip fromRow result) [0..nRows - 1]

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
        ty <- LibPQ.ftype result column
        case fromField ty . Encoding.decodeUtf8 =<< mbField of
          Nothing -> do
            format <- LibPQ.fformat result column
            printf "field %s: %s (oid: %s, format: %s)\n" (show name) (show mbField) (show ty) (show format)
            pure Nothing
          Just value ->
            pure $ Just $ M1 $ K1 value
    where
      name = Encoding.encodeUtf8 $ Text.pack $ symbolVal (Proxy :: Proxy nameSym)