Array.hs

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