{-# LANGUAGE FlexibleInstances #-}

module Argo.Class.FromValue where

import qualified Argo.Decoder as Decoder
import qualified Argo.Json.Number as Number
import qualified Argo.Json.Value as Value
import qualified Argo.Pattern as Pattern
import qualified Argo.Pointer.Pointer as Pointer
import qualified Argo.Result as Result
import qualified Argo.Vendor.Text as Text
import qualified Data.Bits as Bits
import qualified Data.Int as Int
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Word as Word

class FromValue a where
    fromValue :: Value.Value -> Result.Result a

instance FromValue Value.Value where
    fromValue :: Value -> Result Value
fromValue = Value -> Result Value
forall a. a -> Result a
Result.Success

instance FromValue Bool where
    fromValue :: Value -> Result Bool
fromValue = String -> (Bool -> Result Bool) -> Value -> Result Bool
forall a. String -> (Bool -> Result a) -> Value -> Result a
withBoolean String
"Bool" Bool -> Result Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromValue Char where
    fromValue :: Value -> Result Char
fromValue = String -> (Text -> Result Char) -> Value -> Result Char
forall a. String -> (Text -> Result a) -> Value -> Result a
withString String
"Char" ((Text -> Result Char) -> Value -> Result Char)
-> (Text -> Result Char) -> Value -> Result Char
forall a b. (a -> b) -> a -> b
$ \ Text
x -> case Text -> Maybe (Char, Text)
Text.uncons Text
x of
        Just (Char
y, Text
z) | Text -> Bool
Text.null Text
z -> Char -> Result Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
y
        Maybe (Char, Text)
_ -> String -> Result Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Result Char) -> String -> Result Char
forall a b. (a -> b) -> a -> b
$ String
"expected single character but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
x

instance FromValue Int where
    fromValue :: Value -> Result Int
fromValue = Value -> Result Int
forall a. (Integral a, Bits a) => Value -> Result a
viaInteger

instance FromValue Int.Int8 where
    fromValue :: Value -> Result Int8
fromValue = Value -> Result Int8
forall a. (Integral a, Bits a) => Value -> Result a
viaInteger

instance FromValue Int.Int16 where
    fromValue :: Value -> Result Int16
fromValue = Value -> Result Int16
forall a. (Integral a, Bits a) => Value -> Result a
viaInteger

instance FromValue Int.Int32 where
    fromValue :: Value -> Result Int32
fromValue = Value -> Result Int32
forall a. (Integral a, Bits a) => Value -> Result a
viaInteger

instance FromValue Int.Int64 where
    fromValue :: Value -> Result Int64
fromValue = Value -> Result Int64
forall a. (Integral a, Bits a) => Value -> Result a
viaInteger

instance FromValue Word where
    fromValue :: Value -> Result Word
fromValue = Value -> Result Word
forall a. (Integral a, Bits a) => Value -> Result a
viaInteger

instance FromValue Word.Word8 where
    fromValue :: Value -> Result Word8
fromValue = Value -> Result Word8
forall a. (Integral a, Bits a) => Value -> Result a
viaInteger

instance FromValue Word.Word16 where
    fromValue :: Value -> Result Word16
fromValue = Value -> Result Word16
forall a. (Integral a, Bits a) => Value -> Result a
viaInteger

instance FromValue Word.Word32 where
    fromValue :: Value -> Result Word32
fromValue = Value -> Result Word32
forall a. (Integral a, Bits a) => Value -> Result a
viaInteger

instance FromValue Word.Word64 where
    fromValue :: Value -> Result Word64
fromValue = Value -> Result Word64
forall a. (Integral a, Bits a) => Value -> Result a
viaInteger

instance FromValue Integer where
    fromValue :: Value -> Result Integer
fromValue = String
-> (Integer -> Integer -> Result Integer)
-> Value
-> Result Integer
forall a.
String -> (Integer -> Integer -> Result a) -> Value -> Result a
withNumber String
"Integer" ((Integer -> Integer -> Result Integer) -> Value -> Result Integer)
-> (Integer -> Integer -> Result Integer)
-> Value
-> Result Integer
forall a b. (a -> b) -> a -> b
$ \ Integer
x Integer
y ->
        if Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
        then String -> Result Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Result Integer) -> String -> Result Integer
forall a b. (a -> b) -> a -> b
$ String
"expected integer but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show (Integer -> Integer -> Value
Pattern.Number Integer
x Integer
y)
        else Integer -> Result Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Result Integer) -> Integer -> Result Integer
forall a b. (a -> b) -> a -> b
$ Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
y

instance FromValue Float where
    fromValue :: Value -> Result Float
fromValue = String
-> (Integer -> Integer -> Result Float) -> Value -> Result Float
forall a.
String -> (Integer -> Integer -> Result a) -> Value -> Result a
withNumber String
"Float" ((Integer -> Integer -> Result Float) -> Value -> Result Float)
-> (Integer -> Integer -> Result Float) -> Value -> Result Float
forall a b. (a -> b) -> a -> b
$ \ Integer
x Integer
y ->
        Float -> Result Float
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Result Float)
-> (Number -> Float) -> Number -> Result Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Float
forall a. Fractional a => Rational -> a
fromRational (Rational -> Float) -> (Number -> Rational) -> Number -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Number -> Rational
Number.toRational (Number -> Result Float) -> Number -> Result Float
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Number
Number.Number Integer
x Integer
y

instance FromValue Double where
    fromValue :: Value -> Result Double
fromValue = String
-> (Integer -> Integer -> Result Double) -> Value -> Result Double
forall a.
String -> (Integer -> Integer -> Result a) -> Value -> Result a
withNumber String
"Double" ((Integer -> Integer -> Result Double) -> Value -> Result Double)
-> (Integer -> Integer -> Result Double) -> Value -> Result Double
forall a b. (a -> b) -> a -> b
$ \ Integer
x Integer
y ->
        Double -> Result Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Result Double)
-> (Number -> Double) -> Number -> Result Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> (Number -> Rational) -> Number -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Number -> Rational
Number.toRational (Number -> Result Double) -> Number -> Result Double
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Number
Number.Number Integer
x Integer
y

instance {-# OVERLAPPING #-} FromValue String where
    fromValue :: Value -> Result String
fromValue = (Text -> String) -> Result Text -> Result String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
Text.unpack (Result Text -> Result String)
-> (Value -> Result Text) -> Value -> Result String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Result Text
forall a. FromValue a => Value -> Result a
fromValue

instance FromValue Text.Text where
    fromValue :: Value -> Result Text
fromValue = String -> (Text -> Result Text) -> Value -> Result Text
forall a. String -> (Text -> Result a) -> Value -> Result a
withString String
"Text" Text -> Result Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromValue Text.LazyText where
    fromValue :: Value -> Result LazyText
fromValue = (Text -> LazyText) -> Result Text -> Result LazyText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> LazyText
Text.fromStrict (Result Text -> Result LazyText)
-> (Value -> Result Text) -> Value -> Result LazyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Result Text
forall a. FromValue a => Value -> Result a
fromValue

instance FromValue a => FromValue (Maybe a) where
    fromValue :: Value -> Result (Maybe a)
fromValue Value
x = case Value
x of
        Value
Pattern.Null -> Maybe a -> Result (Maybe 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) -> Result a -> Result (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Result a
forall a. FromValue a => Value -> Result a
fromValue Value
x

instance FromValue () where
    fromValue :: Value -> Result ()
fromValue = String -> (Array -> Result ()) -> Value -> Result ()
forall a. String -> (Array -> Result a) -> Value -> Result a
withArray String
"()" ((Array -> Result ()) -> Value -> Result ())
-> (Array -> Result ()) -> Value -> Result ()
forall a b. (a -> b) -> a -> b
$ \ Array
xs -> case Array
xs of
        [] -> () -> Result ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Array
_ -> String -> Result ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Result ()) -> String -> Result ()
forall a b. (a -> b) -> a -> b
$ String
"expected empty list but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Array -> String
forall a. Show a => a -> String
show Array
xs

instance (FromValue a, FromValue b) => FromValue (a, b) where
    fromValue :: Value -> Result (a, b)
fromValue = String -> (Array -> Result (a, b)) -> Value -> Result (a, b)
forall a. String -> (Array -> Result a) -> Value -> Result a
withArray String
"(a, b)" ((Array -> Result (a, b)) -> Value -> Result (a, b))
-> (Array -> Result (a, b)) -> Value -> Result (a, b)
forall a b. (a -> b) -> a -> b
$ \ Array
xs -> case Array
xs of
        [Value
x, Value
y] -> (,) (a -> b -> (a, b)) -> Result a -> Result (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Result a
forall a. FromValue a => Value -> Result a
fromValue Value
x Result (b -> (a, b)) -> Result b -> Result (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Result b
forall a. FromValue a => Value -> Result a
fromValue Value
y
        Array
_ -> String -> Result (a, b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Result (a, b)) -> String -> Result (a, b)
forall a b. (a -> b) -> a -> b
$ String
"expected tuple but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Array -> String
forall a. Show a => a -> String
show Array
xs

instance FromValue a => FromValue [a] where
    fromValue :: Value -> Result [a]
fromValue = String -> (Array -> Result [a]) -> Value -> Result [a]
forall a. String -> (Array -> Result a) -> Value -> Result a
withArray String
"[a]" ((Array -> Result [a]) -> Value -> Result [a])
-> (Array -> Result [a]) -> Value -> Result [a]
forall a b. (a -> b) -> a -> b
$ (Value -> Result a) -> Array -> Result [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Result a
forall a. FromValue a => Value -> Result a
fromValue

instance FromValue a => FromValue (NonEmpty.NonEmpty a) where
    fromValue :: Value -> Result (NonEmpty a)
fromValue Value
value = do
        [a]
list <- Value -> Result [a]
forall a. FromValue a => Value -> Result a
fromValue Value
value
        case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [a]
list of
            Maybe (NonEmpty a)
Nothing -> String -> Result (NonEmpty a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected empty list"
            Just NonEmpty a
nonEmpty -> NonEmpty a -> Result (NonEmpty a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty a
nonEmpty

instance FromValue a => FromValue (Map.Map Text.Text a) where
    fromValue :: Value -> Result (Map Text a)
fromValue = String
-> (Object -> Result (Map Text a)) -> Value -> Result (Map Text a)
forall a. String -> (Object -> Result a) -> Value -> Result a
withObject String
"Map"
        ((Object -> Result (Map Text a)) -> Value -> Result (Map Text a))
-> (Object -> Result (Map Text a)) -> Value -> Result (Map Text a)
forall a b. (a -> b) -> a -> b
$ ([(Text, a)] -> Map Text a)
-> Result [(Text, a)] -> Result (Map Text a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        (Result [(Text, a)] -> Result (Map Text a))
-> (Object -> Result [(Text, a)]) -> Object -> Result (Map Text a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Member -> Result (Text, a)) -> Object -> Result [(Text, a)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\ (Pattern.Member (Pattern.Name Text
k) Value
v) -> (,) Text
k (a -> (Text, a)) -> Result a -> Result (Text, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Result a
forall a. FromValue a => Value -> Result a
fromValue Value
v)

instance FromValue Pointer.Pointer where
    fromValue :: Value -> Result Pointer
fromValue = String -> (Text -> Result Pointer) -> Value -> Result Pointer
forall a. String -> (Text -> Result a) -> Value -> Result a
withString String
"Pointer"
        ((Text -> Result Pointer) -> Value -> Result Pointer)
-> (Text -> Result Pointer) -> Value -> Result Pointer
forall a b. (a -> b) -> a -> b
$ ((ByteString, Pointer) -> Pointer)
-> Result (ByteString, Pointer) -> Result Pointer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, Pointer) -> Pointer
forall a b. (a, b) -> b
snd
        (Result (ByteString, Pointer) -> Result Pointer)
-> (Text -> Result (ByteString, Pointer)) -> Text -> Result Pointer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decoder Pointer -> ByteString -> Result (ByteString, Pointer)
forall a. Decoder a -> ByteString -> Result (ByteString, a)
Decoder.run (Decoder Pointer
Pointer.decode Decoder Pointer -> Decoder () -> Decoder Pointer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Decoder ()
Decoder.eof)
        (ByteString -> Result (ByteString, Pointer))
-> (Text -> ByteString) -> Text -> Result (ByteString, Pointer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8

withBoolean :: String -> (Bool -> Result.Result a) -> Value.Value -> Result.Result a
withBoolean :: String -> (Bool -> Result a) -> Value -> Result a
withBoolean String
s Bool -> Result a
f Value
x = case Value
x of
    Pattern.Boolean Bool
y -> Bool -> Result a
f Bool
y
    Value
_ -> String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ String
"expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
x

withNumber :: String -> (Integer -> Integer -> Result.Result a) -> Value.Value -> Result.Result a
withNumber :: String -> (Integer -> Integer -> Result a) -> Value -> Result a
withNumber String
s Integer -> Integer -> Result a
f Value
x = case Value
x of
    Pattern.Number Integer
y Integer
z -> Integer -> Integer -> Result a
f Integer
y Integer
z
    Value
_ -> String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ String
"expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
x

withString :: String -> (Text.Text -> Result.Result a) -> Value.Value -> Result.Result a
withString :: String -> (Text -> Result a) -> Value -> Result a
withString String
s Text -> Result a
f Value
x = case Value
x of
    Pattern.String Text
y -> Text -> Result a
f Text
y
    Value
_ -> String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ String
"expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
x

withArray :: String -> (Pattern.Array -> Result.Result a) -> Value.Value -> Result.Result a
withArray :: String -> (Array -> Result a) -> Value -> Result a
withArray String
s Array -> Result a
f Value
x = case Value
x of
    Pattern.Array Array
y -> Array -> Result a
f Array
y
    Value
_ -> String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ String
"expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
x

withObject :: String -> (Pattern.Object -> Result.Result a) -> Value.Value -> Result.Result a
withObject :: String -> (Object -> Result a) -> Value -> Result a
withObject String
s Object -> Result a
f Value
x = case Value
x of
    Pattern.Object Object
y -> Object -> Result a
f Object
y
    Value
_ -> String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ String
"expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
x

viaInteger :: (Integral a, Bits.Bits a) => Value.Value -> Result.Result a
viaInteger :: Value -> Result a
viaInteger Value
value = do
    Integer
integer <- Value -> Result Integer
forall a. FromValue a => Value -> Result a
fromValue Value
value
    case Integer -> Maybe a
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
Bits.toIntegralSized (Integer
integer :: Integer) of
        Maybe a
Nothing -> String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ String
"integer out of bounds " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
integer
        Just a
x -> a -> Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x