{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}

-- The derived Alt instance for Cell causes this.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Things in this module are dedicated to parsing Postgres values independent of their format or
-- type.
module PostgreSQL.Result.Cell
  ( Cell (..)
  , ignored
  , raw
  , text
  , readable
  , validate
  )
where

import           Control.Monad ((>=>))
import           Control.Monad.Except (Except, ExceptT (..))
import           Control.Monad.Reader (ReaderT (..))
import           Data.Bifunctor (first)
import           Data.ByteString (ByteString)
import           Data.Functor.Alt (Alt (..))
import           Data.Functor.Identity (Identity (..))
import           Data.List.NonEmpty (NonEmpty)
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Text.Encoding (decodeUtf8')
import           PostgreSQL.Types (Value (..))
import           Text.Read (readEither)

-- | Cell value parser
--
-- @since 0.0.0
newtype Cell a = Cell
  { Cell a -> Value -> Either (NonEmpty Text) a
parseCell :: Value -> Either (NonEmpty Text) a }
  deriving stock Functor -- ^ @since 0.0.0

-- | @since 0.0.0
deriving via ReaderT Value (Except (NonEmpty Text)) instance Alt Cell

-- | Do not parse the cell at all.
--
-- @since 0.0.0
ignored :: Cell ()
ignored :: Cell ()
ignored = (Value -> Either (NonEmpty Text) ()) -> Cell ()
forall a. (Value -> Either (NonEmpty Text) a) -> Cell a
Cell ((Value -> Either (NonEmpty Text) ()) -> Cell ())
-> (Value -> Either (NonEmpty Text) ()) -> Cell ()
forall a b. (a -> b) -> a -> b
$ \Value
_ -> () -> Either (NonEmpty Text) ()
forall a b. b -> Either a b
Right ()

{-# INLINE ignored #-}

-- | Get the raw cell value. Does not allow @NULL@.
--
-- @since 0.0.0
raw :: Cell ByteString
raw :: Cell ByteString
raw = (Value -> Either (NonEmpty Text) ByteString) -> Cell ByteString
forall a. (Value -> Either (NonEmpty Text) a) -> Cell a
Cell ((Value -> Either (NonEmpty Text) ByteString) -> Cell ByteString)
-> (Value -> Either (NonEmpty Text) ByteString) -> Cell ByteString
forall a b. (a -> b) -> a -> b
$ \case
  Value
Null -> NonEmpty Text -> Either (NonEmpty Text) ByteString
forall a b. a -> Either a b
Left [Item (NonEmpty Text)
"Can't be NULL"]
  Value ByteString
encoded -> ByteString -> Either (NonEmpty Text) ByteString
forall a b. b -> Either a b
Right ByteString
encoded

{-# INLINE raw #-}

-- | Parse as UTF-8 'Text'. Does not allow @NULL@.
--
-- @since 0.0.0
text :: Cell Text
text :: Cell Text
text = Cell ByteString -> (ByteString -> Either Text Text) -> Cell Text
forall a b. Cell a -> (a -> Either Text b) -> Cell b
validate Cell ByteString
raw ((UnicodeException -> Text)
-> Either UnicodeException Text -> Either Text Text
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
Text.pack (String -> Text)
-> (UnicodeException -> String) -> UnicodeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnicodeException -> String
forall a. Show a => a -> String
show) (Either UnicodeException Text -> Either Text Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Either Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8')

{-# INLINE text #-}

-- | Parse something using its 'Read' instance via 'text'. Rejects @NULL@ values.
--
-- @since 0.0.0
readable :: Read a => Cell a
readable :: Cell a
readable = Cell Text -> (Text -> Either Text a) -> Cell a
forall a b. Cell a -> (a -> Either Text b) -> Cell b
validate Cell Text
text ((String -> Text) -> Either String a -> Either Text a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
Text.pack (Either String a -> Either Text a)
-> (Text -> Either String a) -> Text -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a. Read a => String -> Either String a
readEither (String -> Either String a)
-> (Text -> String) -> Text -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)

{-# INLINE readable #-}

-- | Validate the given cell parser.
--
-- @since 0.0.0
validate :: Cell a -> (a -> Either Text b) -> Cell b
validate :: Cell a -> (a -> Either Text b) -> Cell b
validate (Cell Value -> Either (NonEmpty Text) a
run) a -> Either Text b
f = (Value -> Either (NonEmpty Text) b) -> Cell b
forall a. (Value -> Either (NonEmpty Text) a) -> Cell a
Cell (Value -> Either (NonEmpty Text) a
run (Value -> Either (NonEmpty Text) a)
-> (a -> Either (NonEmpty Text) b)
-> Value
-> Either (NonEmpty Text) b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Text -> NonEmpty Text)
-> Either Text b -> Either (NonEmpty Text) b
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> NonEmpty Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text b -> Either (NonEmpty Text) b)
-> (a -> Either Text b) -> a -> Either (NonEmpty Text) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either Text b
f)

{-# INLINE validate #-}