{-# 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)