{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {- HLINT ignore "Use <&>" -} module Data.RdsData.Decode.Array ( DecodeArray(..) , decodeArrayFailedMessage , arrays , bools , doubles , integers , texts , ints , int8s , int16s , int32s , int64s , words , word8s , word16s , word32s , word64s , lazyTexts , strings , jsons , timesOfDay , utcTimes , days , uuids ) where import Control.Applicative import Data.Int import Data.RdsData.Internal.Aeson import Data.RdsData.Types.Array import Data.Text (Text) import Data.Time import Data.UUID (UUID) import Data.Word import Prelude hiding (maybe, null, words) import qualified Data.Aeson as J import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT import qualified Data.UUID as UUID import qualified Prelude as P newtype DecodeArray a = DecodeArray { decodeArray :: Array -> Either Text a } deriving Functor instance Applicative DecodeArray where pure a = DecodeArray \_ -> Right a DecodeArray f <*> DecodeArray a = DecodeArray \v -> f v <*> a v instance Alternative DecodeArray where empty = DecodeArray \_ -> Left "empty" DecodeArray a <|> DecodeArray b = DecodeArray \v -> either (const (b v)) Right (a v) instance Monad DecodeArray where DecodeArray a >>= f = DecodeArray \v -> do a' <- a v decodeArray (f a') v -------------------------------------------------------------------------------- decodeArrayFailedMessage :: Text -> Text -> Maybe Text -> Array -> Text decodeArrayFailedMessage item type_ reason value = mconcat [ "Failed to decode " <> item <> " of type " <> type_ <> " from Array of " <> toJsonText value , P.maybe "" (" because " <>) reason ] -------------------------------------------------------------------------------- integers :: DecodeArray [Integer] integers = DecodeArray \v -> case v of ArrayOfIntegers es -> Right es _ -> Left $ decodeArrayFailedMessage "integers" "ArrayOfIntegers" Nothing v texts :: DecodeArray [Text] texts = DecodeArray \v -> case v of ArrayOfTexts es -> Right es _ -> Left $ decodeArrayFailedMessage "texts" "ArrayOfStrings" Nothing v bools :: DecodeArray [Bool] bools = DecodeArray \v -> case v of ArrayOfBools es -> Right es _ -> Left $ decodeArrayFailedMessage "bools" "ArrayOfBooleans" Nothing v doubles :: DecodeArray [Double] doubles = DecodeArray \v -> case v of ArrayOfDoubles es -> Right es _ -> Left $ decodeArrayFailedMessage "doubles" "ArrayOfDoubles" Nothing v arrays :: DecodeArray [Array] arrays = DecodeArray \v -> case v of ArrayOfArrays es -> Right es _ -> Left $ decodeArrayFailedMessage "arrays" "ArrayOfArrays" Nothing v -------------------------------------------------------------------------------- ints :: DecodeArray [Int] ints = fmap fromIntegral <$> integers int8s :: DecodeArray [Int8] int8s = fmap fromIntegral <$> integers int16s :: DecodeArray [Int16] int16s = fmap fromIntegral <$> integers int32s :: DecodeArray [Int32] int32s = fmap fromIntegral <$> integers int64s :: DecodeArray [Int64] int64s = fmap fromIntegral <$> integers words :: DecodeArray [Word] words = fmap fromIntegral <$> integers word8s :: DecodeArray [Word8] word8s = fmap fromIntegral <$> integers word16s :: DecodeArray [Word16] word16s = fmap fromIntegral <$> integers word32s :: DecodeArray [Word32] word32s = fmap fromIntegral <$> integers word64s :: DecodeArray [Word64] word64s = fmap fromIntegral <$> integers lazyTexts :: DecodeArray [LT.Text] lazyTexts = fmap LT.fromStrict <$> texts strings :: DecodeArray [String] strings = fmap T.unpack <$> texts jsons :: DecodeArray [J.Value] jsons = do ts <- texts case traverse (J.eitherDecodeStrict' . T.encodeUtf8) ts of Right js -> pure js Left e -> DecodeArray \_ -> Left $ "Failed to decode JSON: " <> T.pack e timesOfDay :: DecodeArray [TimeOfDay] timesOfDay = do ts <- texts case traverse (parseTimeM True defaultTimeLocale "%H:%M:%S". T.unpack) ts of Just tod -> pure tod Nothing -> DecodeArray \_ -> Left "Failed to decode TimeOfDay" utcTimes :: DecodeArray [UTCTime] utcTimes = do ts <- texts case traverse (parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" . T.unpack) ts of Just utct -> pure utct Nothing -> DecodeArray \_ -> Left "Failed to decode UTCTime" days :: DecodeArray [Day] days = do ts <- texts case traverse (parseTimeM True defaultTimeLocale "%Y-%m-%d" . T.unpack) ts of Just d -> pure d Nothing -> DecodeArray \_ -> Left "Failed to decode Day" uuids :: DecodeArray [UUID] uuids = do ts <- texts case traverse (UUID.fromString . T.unpack) ts of Just u -> pure u Nothing -> DecodeArray \_ -> Left "Failed to decode UUID"