{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

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

import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT)
import Data.ByteString (ByteString)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Database.PostgreSQL.LibPQ
  ( Column
  , Connection
  , Result
  , Row
  )
import GHC.Generics (C, D, Generic, K1 (..), M1 (..), Meta (..), Rec0, Rep, S, to, (:*:) (..))
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)

import qualified Data.Text as Text
import qualified Data.Text.Encoding as Encoding
import qualified Database.PostgreSQL.LibPQ as LibPQ

import Database.PostgreSQL.Opium.Error (Error (..))
import Database.PostgreSQL.Opium.FromField (FieldError (..), FromField (..))

execParams :: Connection -> ByteString -> IO (Either Error Result)
execParams conn query = do
  LibPQ.execParams conn query [] LibPQ.Text >>= \case
    Nothing ->
      pure $ Left ErrorNoResult
    Just result -> do
      status <- LibPQ.resultStatus result
      mbMessage <- LibPQ.resultErrorMessage result
      case mbMessage of
        Just "" -> pure $ Right result
        Just message -> pure $ Left $ ErrorInvalidResult status $ Encoding.decodeUtf8 message
        Nothing -> pure $ Right result

fetch_ :: FromRow a => Connection -> ByteString -> IO (Either Error [a])
fetch_ conn query = runExceptT $ do
  result <- ExceptT $ execParams conn query
  ExceptT $ fetchResult result

fetchResult :: FromRow a => Result -> IO (Either Error [a])
fetchResult result = do
  nRows <- LibPQ.ntuples result
  runExceptT $ mapM (ExceptT . flip fromRow result) [0..nRows - 1]

class FromRow a where
  fromRow :: Row -> Result -> IO (Either Error a)
  default fromRow :: (Generic a, FromRow' (Rep a)) => Row -> Result -> IO (Either Error a)
  fromRow row result = fmap to <$> fromRow' row result

class FromRow' f where
  fromRow' :: Row -> Result -> IO (Either Error (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

-- TODO: Can we clean this up?

decodeField
  :: FromField t
  => Text
  -> (Row -> Maybe t -> Either Error t')
  -> Row
  -> Result
  -> IO (Either Error (M1 S ('MetaSel ('Just (nameSym :: Symbol)) nu ns dl) (Rec0 t') p))
decodeField nameText g row result = runExceptT $ do
    column <- getColumn
    oid <- ExceptT $ Right <$> LibPQ.ftype result column
    mbField <- getValue column
    value <- case mbField of
      Nothing ->
        except $ g row Nothing 
      Just field -> do
        value <- except $ mapLeft (ErrorDecode row nameText) $ fromField oid $ Encoding.decodeUtf8 field
        except $ g row $ Just value
    pure $ M1 $ K1 value
    where
      name = Encoding.encodeUtf8 nameText

      getColumn :: ExceptT Error IO Column
      getColumn = ExceptT $
        maybe (Left $ ErrorMissingColumn nameText) Right <$> LibPQ.fnumber result name

      getValue :: Column -> ExceptT Error IO (Maybe ByteString)
      getValue column = ExceptT $ Right <$> LibPQ.getvalue result row column

instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
  fromRow' = decodeField nameText $ \row -> \case
    Nothing -> Left $ ErrorUnexpectedNull row nameText
    Just value -> Right value
    where
      nameText = Text.pack $ symbolVal (Proxy :: Proxy nameSym)

instance {-# OVERLAPPING #-} (KnownSymbol nameSym, FromField t) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where
  fromRow' = decodeField nameText $ const Right
    where
      nameText = Text.pack $ symbolVal (Proxy :: Proxy nameSym)

mapLeft :: (b -> c) -> Either b a -> Either c a
mapLeft f (Left l) = Left $ f l
mapLeft _ (Right r) = Right r