{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.RdsData.Decode.Row
  ( DecodeRow(..)
  , integer
  , int
  , int8
  , int16
  , int32
  , int64
  , bool
  , double
  , string
  , text
  , lazyText
  , word
  , word8
  , word16
  , word32
  , word64
  , bytestring
  , lazyBytestring
  , timeOfDay
  , day
  , ulid
  , utcTime
  , uuid
  , ignore
  , json
  , maybe
  , column
  , decodeRow
  , decodeRows
  ) where

import Control.Monad.Except
import Control.Monad.State
import Data.ByteString (ByteString)
import Control.Monad
import Data.Functor.Identity ( Identity )
import Data.Int
import Data.RdsData.Decode.Value (DecodeValue)
import Data.RdsData.Types.Value
import Data.Text
import Data.Time
import Data.ULID (ULID)
import Data.UUID (UUID)
import Data.Word
import Prelude hiding (maybe)

import qualified Data.Aeson                    as J
import qualified Data.ByteString.Lazy          as LBS
import qualified Data.RdsData.Decode.Value     as DV
import qualified Data.RdsData.Internal.Convert as CONV
import qualified Data.Text                     as T
import qualified Data.Text.Lazy                as LT
import qualified Data.UUID                     as UUID

newtype DecodeRow a = DecodeRow
  { forall a. DecodeRow a -> ExceptT Text (StateT [Value] Identity) a
unDecodeRow :: ExceptT Text (StateT [Value] Identity) a
  }
  deriving (Functor DecodeRow
Functor DecodeRow =>
(forall a. a -> DecodeRow a)
-> (forall a b. DecodeRow (a -> b) -> DecodeRow a -> DecodeRow b)
-> (forall a b c.
    (a -> b -> c) -> DecodeRow a -> DecodeRow b -> DecodeRow c)
-> (forall a b. DecodeRow a -> DecodeRow b -> DecodeRow b)
-> (forall a b. DecodeRow a -> DecodeRow b -> DecodeRow a)
-> Applicative DecodeRow
forall a. a -> DecodeRow a
forall a b. DecodeRow a -> DecodeRow b -> DecodeRow a
forall a b. DecodeRow a -> DecodeRow b -> DecodeRow b
forall a b. DecodeRow (a -> b) -> DecodeRow a -> DecodeRow b
forall a b c.
(a -> b -> c) -> DecodeRow a -> DecodeRow b -> DecodeRow c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> DecodeRow a
pure :: forall a. a -> DecodeRow a
$c<*> :: forall a b. DecodeRow (a -> b) -> DecodeRow a -> DecodeRow b
<*> :: forall a b. DecodeRow (a -> b) -> DecodeRow a -> DecodeRow b
$cliftA2 :: forall a b c.
(a -> b -> c) -> DecodeRow a -> DecodeRow b -> DecodeRow c
liftA2 :: forall a b c.
(a -> b -> c) -> DecodeRow a -> DecodeRow b -> DecodeRow c
$c*> :: forall a b. DecodeRow a -> DecodeRow b -> DecodeRow b
*> :: forall a b. DecodeRow a -> DecodeRow b -> DecodeRow b
$c<* :: forall a b. DecodeRow a -> DecodeRow b -> DecodeRow a
<* :: forall a b. DecodeRow a -> DecodeRow b -> DecodeRow a
Applicative, (forall a b. (a -> b) -> DecodeRow a -> DecodeRow b)
-> (forall a b. a -> DecodeRow b -> DecodeRow a)
-> Functor DecodeRow
forall a b. a -> DecodeRow b -> DecodeRow a
forall a b. (a -> b) -> DecodeRow a -> DecodeRow b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> DecodeRow a -> DecodeRow b
fmap :: forall a b. (a -> b) -> DecodeRow a -> DecodeRow b
$c<$ :: forall a b. a -> DecodeRow b -> DecodeRow a
<$ :: forall a b. a -> DecodeRow b -> DecodeRow a
Functor, Applicative DecodeRow
Applicative DecodeRow =>
(forall a b. DecodeRow a -> (a -> DecodeRow b) -> DecodeRow b)
-> (forall a b. DecodeRow a -> DecodeRow b -> DecodeRow b)
-> (forall a. a -> DecodeRow a)
-> Monad DecodeRow
forall a. a -> DecodeRow a
forall a b. DecodeRow a -> DecodeRow b -> DecodeRow b
forall a b. DecodeRow a -> (a -> DecodeRow b) -> DecodeRow b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. DecodeRow a -> (a -> DecodeRow b) -> DecodeRow b
>>= :: forall a b. DecodeRow a -> (a -> DecodeRow b) -> DecodeRow b
$c>> :: forall a b. DecodeRow a -> DecodeRow b -> DecodeRow b
>> :: forall a b. DecodeRow a -> DecodeRow b -> DecodeRow b
$creturn :: forall a. a -> DecodeRow a
return :: forall a. a -> DecodeRow a
Monad, MonadState [Value], MonadError Text)

instance MonadFail DecodeRow where
  fail :: forall a. String -> DecodeRow a
fail = ExceptT Text (StateT [Value] Identity) a -> DecodeRow a
forall a. ExceptT Text (StateT [Value] Identity) a -> DecodeRow a
DecodeRow (ExceptT Text (StateT [Value] Identity) a -> DecodeRow a)
-> (String -> ExceptT Text (StateT [Value] Identity) a)
-> String
-> DecodeRow a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ExceptT Text (StateT [Value] Identity) a
forall a. Text -> ExceptT Text (StateT [Value] Identity) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text (StateT [Value] Identity) a)
-> (String -> Text)
-> String
-> ExceptT Text (StateT [Value] Identity) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack

maybe :: DecodeRow a -> DecodeRow (Maybe a)
maybe :: forall a. DecodeRow a -> DecodeRow (Maybe a)
maybe DecodeRow a
r = do
  [Value]
cs <- DecodeRow [Value]
forall s (m :: * -> *). MonadState s m => m s
get
  case [Value]
cs of
    Value
ValueOfNull : [Value]
vs -> do
      [Value] -> DecodeRow ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [Value]
vs
      Maybe a -> DecodeRow (Maybe a)
forall a. a -> DecodeRow a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    [Value]
_ -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> DecodeRow a -> DecodeRow (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DecodeRow a
r

decodeRowValue :: ()
  => MonadError Text m
  => DecodeValue a
  -> Value
  -> m a
decodeRowValue :: forall (m :: * -> *) a.
MonadError Text m =>
DecodeValue a -> Value -> m a
decodeRowValue DecodeValue a
decoder Value
v =
  case DecodeValue a -> Value -> Either Text a
forall a. DecodeValue a -> Value -> Either Text a
DV.decodeValue DecodeValue a
decoder Value
v of
    Right a
a -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Left Text
e -> Text -> m a
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode Value: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e

column :: ()
  => DecodeValue a
  -> DecodeRow a
column :: forall a. DecodeValue a -> DecodeRow a
column DecodeValue a
decoder = do
  [Value]
cs <- DecodeRow [Value]
forall s (m :: * -> *). MonadState s m => m s
get
  case [Value]
cs of
    Value
v : [Value]
vs -> do
      a
s <- DecodeValue a -> Value -> DecodeRow a
forall (m :: * -> *) a.
MonadError Text m =>
DecodeValue a -> Value -> m a
decodeRowValue DecodeValue a
decoder Value
v
      [Value] -> DecodeRow ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [Value]
vs
      a -> DecodeRow a
forall a. a -> DecodeRow a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
s
    [] -> do
      Text -> DecodeRow a
forall a. Text -> DecodeRow a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Expected RdsText, but got no more values in row."

integer :: DecodeRow Integer
integer :: DecodeRow Integer
integer =
  DecodeValue Integer -> DecodeRow Integer
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Integer
DV.integer

int :: DecodeRow Int
int :: DecodeRow Int
int =
  DecodeValue Int -> DecodeRow Int
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Int
DV.int

int8 :: DecodeRow Int8
int8 :: DecodeRow Int8
int8 =
  DecodeValue Int8 -> DecodeRow Int8
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Int8
DV.int8

int16 :: DecodeRow Int16
int16 :: DecodeRow Int16
int16 =
  DecodeValue Int16 -> DecodeRow Int16
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Int16
DV.int16

int32 :: DecodeRow Int32
int32 :: DecodeRow Int32
int32 =
  DecodeValue Int32 -> DecodeRow Int32
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Int32
DV.int32

int64 :: DecodeRow Int64
int64 :: DecodeRow Int64
int64 =
  DecodeValue Int64 -> DecodeRow Int64
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Int64
DV.int64

word :: DecodeRow Word
word :: DecodeRow Word
word =
  DecodeValue Word -> DecodeRow Word
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Word
DV.word

word8 :: DecodeRow Word8
word8 :: DecodeRow Word8
word8 =
  DecodeValue Word8 -> DecodeRow Word8
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Word8
DV.word8

word16 :: DecodeRow Word16
word16 :: DecodeRow Word16
word16 =
  DecodeValue Word16 -> DecodeRow Word16
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Word16
DV.word16

word32 :: DecodeRow Word32
word32 :: DecodeRow Word32
word32 =
  DecodeValue Word32 -> DecodeRow Word32
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Word32
DV.word32

word64 :: DecodeRow Word64
word64 :: DecodeRow Word64
word64 =
  DecodeValue Word64 -> DecodeRow Word64
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Word64
DV.word64

text :: DecodeRow Text
text :: DecodeRow Text
text =
  DecodeValue Text -> DecodeRow Text
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Text
DV.text

lazyText :: DecodeRow LT.Text
lazyText :: DecodeRow Text
lazyText =
  DecodeValue Text -> DecodeRow Text
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Text
DV.lazyText

bool :: DecodeRow Bool
bool :: DecodeRow Bool
bool =
  DecodeValue Bool -> DecodeRow Bool
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Bool
DV.bool

double :: DecodeRow Double
double :: DecodeRow Double
double =
  DecodeValue Double -> DecodeRow Double
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Double
DV.double

bytestring :: DecodeRow ByteString
bytestring :: DecodeRow ByteString
bytestring =
  DecodeValue ByteString -> DecodeRow ByteString
forall a. DecodeValue a -> DecodeRow a
column DecodeValue ByteString
DV.bytestring

lazyBytestring :: DecodeRow LBS.ByteString
lazyBytestring :: DecodeRow ByteString
lazyBytestring =
  DecodeValue ByteString -> DecodeRow ByteString
forall a. DecodeValue a -> DecodeRow a
column DecodeValue ByteString
DV.lazyBytestring

string :: DecodeRow String
string :: DecodeRow String
string =
  DecodeValue String -> DecodeRow String
forall a. DecodeValue a -> DecodeRow a
column DecodeValue String
DV.string

json :: DecodeRow J.Value
json :: DecodeRow Value
json =
  DecodeValue Value -> DecodeRow Value
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Value
DV.json

timeOfDay :: DecodeRow TimeOfDay
timeOfDay :: DecodeRow TimeOfDay
timeOfDay = do
  Text
t <- DecodeRow Text
text
  case Bool -> TimeLocale -> String -> String -> Maybe TimeOfDay
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%H:%M:%S%Q" (Text -> String
T.unpack Text
t) of
    Just TimeOfDay
a -> TimeOfDay -> DecodeRow TimeOfDay
forall a. a -> DecodeRow a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeOfDay
a
    Maybe TimeOfDay
Nothing -> Text -> DecodeRow TimeOfDay
forall a. Text -> DecodeRow a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> DecodeRow TimeOfDay) -> Text -> DecodeRow TimeOfDay
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse TimeOfDay: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Text -> String
forall a. Show a => a -> String
show Text
t)

ulid :: DecodeRow ULID
ulid :: DecodeRow ULID
ulid = do
  Text
t <- DecodeRow Text
text
  case Text -> Either Text ULID
CONV.textToUlid Text
t of
    Right ULID
a -> ULID -> DecodeRow ULID
forall a. a -> DecodeRow a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ULID
a
    Left Text
msg -> Text -> DecodeRow ULID
forall a. Text -> DecodeRow a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> DecodeRow ULID) -> Text -> DecodeRow ULID
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse ULID: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

utcTime :: DecodeRow UTCTime
utcTime :: DecodeRow UTCTime
utcTime = do
  Text
t <- DecodeRow Text
text
  case Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%d %H:%M:%S" (Text -> String
T.unpack Text
t) of
    Just UTCTime
a -> UTCTime -> DecodeRow UTCTime
forall a. a -> DecodeRow a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
a
    Maybe UTCTime
Nothing -> Text -> DecodeRow UTCTime
forall a. Text -> DecodeRow a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> DecodeRow UTCTime) -> Text -> DecodeRow UTCTime
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse UTCTime: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Text -> String
forall a. Show a => a -> String
show Text
t)

uuid :: DecodeRow UUID
uuid :: DecodeRow UUID
uuid = do
  Text
t <- DecodeRow Text
text
  case String -> Maybe UUID
UUID.fromString (Text -> String
T.unpack Text
t) of
    Just UUID
a -> UUID -> DecodeRow UUID
forall a. a -> DecodeRow a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UUID
a
    Maybe UUID
Nothing -> Text -> DecodeRow UUID
forall a. Text -> DecodeRow a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> DecodeRow UUID) -> Text -> DecodeRow UUID
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse UUID: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Text -> String
forall a. Show a => a -> String
show Text
t)

day :: DecodeRow Day
day :: DecodeRow Day
day = do
  Text
t <- DecodeRow Text
text
  case Bool -> TimeLocale -> String -> String -> Maybe Day
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%d" (Text -> String
T.unpack Text
t) of
    Just Day
a -> Day -> DecodeRow Day
forall a. a -> DecodeRow a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Day
a
    Maybe Day
Nothing -> Text -> DecodeRow Day
forall a. Text -> DecodeRow a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> DecodeRow Day) -> Text -> DecodeRow Day
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse Day: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Text -> String
forall a. Show a => a -> String
show Text
t)

ignore :: DecodeRow ()
ignore :: DecodeRow ()
ignore =
  DecodeRow Value -> DecodeRow ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (DecodeRow Value -> DecodeRow ())
-> DecodeRow Value -> DecodeRow ()
forall a b. (a -> b) -> a -> b
$ DecodeValue Value -> DecodeRow Value
forall a. DecodeValue a -> DecodeRow a
column DecodeValue Value
DV.rdsValue

decodeRow :: DecodeRow a -> [Value] -> Either Text a
decodeRow :: forall a. DecodeRow a -> [Value] -> Either Text a
decodeRow DecodeRow a
r = State [Value] (Either Text a) -> [Value] -> Either Text a
forall s a. State s a -> s -> a
evalState (ExceptT Text (StateT [Value] Identity) a
-> State [Value] (Either Text a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (DecodeRow a -> ExceptT Text (StateT [Value] Identity) a
forall a. DecodeRow a -> ExceptT Text (StateT [Value] Identity) a
unDecodeRow DecodeRow a
r))

decodeRows :: DecodeRow a ->  [[Value]] -> Either Text [a]
decodeRows :: forall a. DecodeRow a -> [[Value]] -> Either Text [a]
decodeRows DecodeRow a
r = ([Value] -> Either Text a) -> [[Value]] -> Either Text [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DecodeRow a -> [Value] -> Either Text a
forall a. DecodeRow a -> [Value] -> Either Text a
decodeRow DecodeRow a
r)