{-# LANGUAGE DefaultSignatures, FlexibleContexts, FlexibleInstances #-}
{-# LANGUAGE EmptyCase #-}

-- | Definition for ron conversion classes, and for using 'GHC.Generics' to
-- encode any datatype into RON.
module Data.Ron.Class
    ( ToRon (..), FromRon (..)
    , ParseResult
    -- * Settings for generic encoding
    , RonSettings (..)
    , RonFlags (..)
    , strictRonSettings, laxRonSettings
    -- * Generic encoding
    , toRonGeneric
    , fromRonGeneric
    , GToRon, GFromRon
    ) where

import Control.Applicative (liftA2)
import Control.Arrow ((***))
import Data.ByteString (ByteString)
import Data.Complex (Complex ((:+)))
import Data.Foldable (toList)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Map.Strict (Map)
import Data.Proxy (Proxy (..))
import Data.Ron.Class.Internal (productSize, ProductSize)
import Data.Scientific (fromFloatDigits, toRealFloat, Scientific)
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8)
import Data.Vector (Vector)
import Data.Word (Word8, Word16, Word32, Word64)
import GHC.Generics
    ( Generic (Rep, from, to), V1, U1 (..), (:+:)(..), (:*:)(..)
    , K1 (..), M1 (..)
    , C, S, D, R
    , Constructor (conName, conIsRecord), Selector (selName), Datatype (datatypeName)
    )

import qualified Data.ByteString as BS
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Vector as Vector

import Data.Ron.Value
import Prelude hiding (fail)


-- | When decoding from ron, this type is used to indicate decode failure.
-- During decoding, multiple failures may be concatenated with a semicolon, and
-- for some functions the string will be thrown with
-- 'Data.Ron.Deserialize.DecodeError'. When implementing your own decoding
-- functions, you should put short one-sentence error descriptions.
--
-- For the next major release, we plan to replace it with a better mechanism
-- that reports error locations and supports long-form content.
type ParseResult = Either String
fail :: String -> ParseResult a
fail :: forall a. String -> ParseResult a
fail = String -> Either String a
forall a b. a -> Either a b
Left

guard :: String -> Bool -> ParseResult ()
guard :: String -> Bool -> ParseResult ()
guard String
_ Bool
True = () -> ParseResult ()
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
guard String
msg Bool
False = String -> ParseResult ()
forall a. String -> ParseResult a
fail String
msg

-- | Like 'Control.Applicative.(<|>)' but collect errors from both sides
(<<|>>) :: ParseResult a -> ParseResult a -> ParseResult a
ParseResult a
pa <<|>> :: forall a. ParseResult a -> ParseResult a -> ParseResult a
<<|>> ParseResult a
pb = case ParseResult a
pa of
    Right a
a -> a -> ParseResult a
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Left String
ea -> case ParseResult a
pb of
        Right a
b -> a -> ParseResult a
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
b
        Left String
eb -> String -> ParseResult a
forall a. String -> ParseResult a
fail (String -> ParseResult a) -> String -> ParseResult a
forall a b. (a -> b) -> a -> b
$ String
ea String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; "String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
eb

-- | A class of values that can be encoded to RON format.
--
-- There are several ways to define an instance:
--
--   1. By producing a 'Value' by hand
--   2. By using 'toRonGeneric'
--   3. By @DerivingVia@ extension and using 'Data.Ron.Class.Deriving.RonWith'
--
-- When using the second option, the encoding parameters are specified with
-- 'RonSettings'. With the third option, the same parameters are specified by a
-- list of settings found in 'Data.Ron.Class.Deriving'.
--
-- The default implementation uses generic encoding with 'laxRonSettings'. You
-- can use other settings like this:
--
-- @
--      instance ToRon MyType where
--          toRon = toRonGeneric strictRonSettings
--              { encodeFlags = RonFlags
--                  { implicitSome = True
--                  , skipSingleConstructor = True
--                  }
--              }
-- @
--
-- Or like this:
--
-- @
--      deriving via (RonWith '[UseStrict, EncodeWith SkipSingleConstructor, EncodeWith ImplicitSome])
--          instance ToRon MyType
-- @
class ToRon a where
    toRon :: a -> Value
    default toRon :: (Generic a, GToRon (Rep a)) => a -> Value
    toRon = a -> Value
forall a. (Generic a, GToRon (Rep a)) => a -> Value
toRonDefault

-- | A class of values that can be restored from RON format
--
-- There are several ways to define an instance:
--
--   1. By deconstructing a 'Value' by hand and producing a value of your type
--   2. By using 'fromRonGeneric'
--   3. By @DerivingVia@ extension and using 'Data.Ron.Class.Deriving.RonWith'
--
-- The default implementation uses generic decoding with 'laxRonSettings'. You
-- can use other settings like this:
--
-- @
--      instance FromRon MyType where
--          fromRon = fromRonGeneric strictRonSettings
--              { decodeFlags = RonFlags
--                  { implicitSome = True
--                  , skipSingleConstructor = True
--                  }
--              }
-- @
--
-- Or like this:
--
-- @
--      deriving via (RonWith '[UseStrict, DecodeWith SkipSingleConstructor, DecodeWith ImplicitSome])
--          instance FromRon MyType
-- @
class FromRon a where
    fromRon :: Value -> ParseResult a
    default fromRon :: (Generic a, GFromRon (Rep a)) => Value -> ParseResult a
    fromRon = Value -> ParseResult a
forall a. (Generic a, GFromRon (Rep a)) => Value -> ParseResult a
fromRonDefault

intInRange :: forall a. (Bounded a, Num a, Integral a) => Integer -> ParseResult a
intInRange :: forall a.
(Bounded a, Num a, Integral a) =>
Integer -> ParseResult a
intInRange Integer
i
    | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
minVal Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
maxVal  = a -> Either String a
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either String a)
-> (Integer -> a) -> Integer -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> a
forall a. Num a => Integer -> a
fromInteger (Integer -> Either String a) -> Integer -> Either String a
forall a b. (a -> b) -> a -> b
$ Integer
i
    | Bool
otherwise  = String -> Either String a
forall a. String -> ParseResult a
fail (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"Value " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not in valid range"
    where
        minVal :: Integer
minVal = a -> Integer
forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
minBound @a)
        maxVal :: Integer
maxVal = a -> Integer
forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound @a)

instance ToRon Int where
    toRon :: Int -> Value
toRon = Integer -> Value
Integral (Integer -> Value) -> (Int -> Integer) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger
instance FromRon Int where
    fromRon :: Value -> ParseResult Int
fromRon (Integral Integer
i) = Integer -> ParseResult Int
forall a.
(Bounded a, Num a, Integral a) =>
Integer -> ParseResult a
intInRange Integer
i
    fromRon Value
_ = String -> ParseResult Int
forall a. String -> ParseResult a
fail String
"Not an integer"
instance ToRon Int8 where
    toRon :: Int8 -> Value
toRon = Integer -> Value
Integral (Integer -> Value) -> (Int8 -> Integer) -> Int8 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Integer
forall a. Integral a => a -> Integer
toInteger
instance FromRon Int8 where
    fromRon :: Value -> ParseResult Int8
fromRon (Integral Integer
i) = Integer -> ParseResult Int8
forall a.
(Bounded a, Num a, Integral a) =>
Integer -> ParseResult a
intInRange Integer
i
    fromRon Value
_ = String -> ParseResult Int8
forall a. String -> ParseResult a
fail String
"Not an integer"
instance ToRon Int16 where
    toRon :: Int16 -> Value
toRon = Integer -> Value
Integral (Integer -> Value) -> (Int16 -> Integer) -> Int16 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Integer
forall a. Integral a => a -> Integer
toInteger
instance FromRon Int16 where
    fromRon :: Value -> ParseResult Int16
fromRon (Integral Integer
i) = Integer -> ParseResult Int16
forall a.
(Bounded a, Num a, Integral a) =>
Integer -> ParseResult a
intInRange Integer
i
    fromRon Value
_ = String -> ParseResult Int16
forall a. String -> ParseResult a
fail String
"Not an integer"
instance ToRon Int32 where
    toRon :: Int32 -> Value
toRon = Integer -> Value
Integral (Integer -> Value) -> (Int32 -> Integer) -> Int32 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Integer
forall a. Integral a => a -> Integer
toInteger
instance FromRon Int32 where
    fromRon :: Value -> ParseResult Int32
fromRon (Integral Integer
i) = Integer -> ParseResult Int32
forall a.
(Bounded a, Num a, Integral a) =>
Integer -> ParseResult a
intInRange Integer
i
    fromRon Value
_ = String -> ParseResult Int32
forall a. String -> ParseResult a
fail String
"Not an integer"
instance ToRon Int64 where
    toRon :: Int64 -> Value
toRon = Integer -> Value
Integral (Integer -> Value) -> (Int64 -> Integer) -> Int64 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger
instance FromRon Int64 where
    fromRon :: Value -> ParseResult Int64
fromRon (Integral Integer
i) = Integer -> ParseResult Int64
forall a.
(Bounded a, Num a, Integral a) =>
Integer -> ParseResult a
intInRange Integer
i
    fromRon Value
_ = String -> ParseResult Int64
forall a. String -> ParseResult a
fail String
"Not an integer"
instance ToRon Word where
    toRon :: Word -> Value
toRon = Integer -> Value
Integral (Integer -> Value) -> (Word -> Integer) -> Word -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Integer
forall a. Integral a => a -> Integer
toInteger
instance FromRon Word where
    fromRon :: Value -> ParseResult Word
fromRon (Integral Integer
i) = Integer -> ParseResult Word
forall a.
(Bounded a, Num a, Integral a) =>
Integer -> ParseResult a
intInRange Integer
i
    fromRon Value
_ = String -> ParseResult Word
forall a. String -> ParseResult a
fail String
"Not an integer"
instance ToRon Word8 where
    toRon :: Word8 -> Value
toRon = Integer -> Value
Integral (Integer -> Value) -> (Word8 -> Integer) -> Word8 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Integer
forall a. Integral a => a -> Integer
toInteger
instance FromRon Word8 where
    fromRon :: Value -> ParseResult Word8
fromRon (Integral Integer
i) = Integer -> ParseResult Word8
forall a.
(Bounded a, Num a, Integral a) =>
Integer -> ParseResult a
intInRange Integer
i
    fromRon Value
_ = String -> ParseResult Word8
forall a. String -> ParseResult a
fail String
"Not an integer"
instance ToRon Word16 where
    toRon :: Word16 -> Value
toRon = Integer -> Value
Integral (Integer -> Value) -> (Word16 -> Integer) -> Word16 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Integer
forall a. Integral a => a -> Integer
toInteger
instance FromRon Word16 where
    fromRon :: Value -> ParseResult Word16
fromRon (Integral Integer
i) = Integer -> ParseResult Word16
forall a.
(Bounded a, Num a, Integral a) =>
Integer -> ParseResult a
intInRange Integer
i
    fromRon Value
_ = String -> ParseResult Word16
forall a. String -> ParseResult a
fail String
"Not an integer"
instance ToRon Word32 where
    toRon :: Word32 -> Value
toRon = Integer -> Value
Integral (Integer -> Value) -> (Word32 -> Integer) -> Word32 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger
instance FromRon Word32 where
    fromRon :: Value -> ParseResult Word32
fromRon (Integral Integer
i) = Integer -> ParseResult Word32
forall a.
(Bounded a, Num a, Integral a) =>
Integer -> ParseResult a
intInRange Integer
i
    fromRon Value
_ = String -> ParseResult Word32
forall a. String -> ParseResult a
fail String
"Not an integer"
instance ToRon Word64 where
    toRon :: Word64 -> Value
toRon = Integer -> Value
Integral (Integer -> Value) -> (Word64 -> Integer) -> Word64 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger
instance FromRon Word64 where
    fromRon :: Value -> ParseResult Word64
fromRon (Integral Integer
i) = Integer -> ParseResult Word64
forall a.
(Bounded a, Num a, Integral a) =>
Integer -> ParseResult a
intInRange Integer
i
    fromRon Value
_ = String -> ParseResult Word64
forall a. String -> ParseResult a
fail String
"Not an integer"
instance ToRon Integer where
    toRon :: Integer -> Value
toRon = Integer -> Value
Integral
instance FromRon Integer where
    fromRon :: Value -> ParseResult Integer
fromRon (Integral Integer
i) = Integer -> ParseResult Integer
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
i
    fromRon Value
_ = String -> ParseResult Integer
forall a. String -> ParseResult a
fail String
"Not an integer"

instance ToRon Scientific where
    toRon :: Scientific -> Value
toRon = Scientific -> Value
Floating
instance FromRon Scientific where
    fromRon :: Value -> ParseResult Scientific
fromRon (Integral Integer
x) = Scientific -> ParseResult Scientific
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific -> ParseResult Scientific)
-> (Integer -> Scientific) -> Integer -> ParseResult Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> ParseResult Scientific)
-> Integer -> ParseResult Scientific
forall a b. (a -> b) -> a -> b
$ Integer
x
    fromRon (Floating Scientific
x) = Scientific -> ParseResult Scientific
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
x
    fromRon Value
_ = String -> ParseResult Scientific
forall a. String -> ParseResult a
fail String
"Not a floating"
instance ToRon Double where
    toRon :: Double -> Value
toRon Double
x
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
x = Text -> Value
Unit Text
"NaN"
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
x = Text -> Value
Unit Text
"inf"
        | Bool
otherwise = Scientific -> Value
Floating (Scientific -> Value) -> (Double -> Scientific) -> Double -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Scientific
forall a. RealFloat a => a -> Scientific
fromFloatDigits (Double -> Value) -> Double -> Value
forall a b. (a -> b) -> a -> b
$ Double
x
instance FromRon Double where
    fromRon :: Value -> ParseResult Double
fromRon (Integral Integer
x) = Double -> ParseResult Double
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> ParseResult Double)
-> (Integer -> Double) -> Integer -> ParseResult Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Integer -> ParseResult Double) -> Integer -> ParseResult Double
forall a b. (a -> b) -> a -> b
$ Integer
x
    fromRon (Floating Scientific
x) = Double -> ParseResult Double
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> ParseResult Double)
-> (Scientific -> Double) -> Scientific -> ParseResult Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat (Scientific -> ParseResult Double)
-> Scientific -> ParseResult Double
forall a b. (a -> b) -> a -> b
$ Scientific
x
    fromRon (Unit Text
"inf") = Double -> ParseResult Double
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> ParseResult Double) -> Double -> ParseResult Double
forall a b. (a -> b) -> a -> b
$! String -> Double
forall a. Read a => String -> a
read String
"Infinity"
    fromRon (Unit Text
"NaN") = Double -> ParseResult Double
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> ParseResult Double) -> Double -> ParseResult Double
forall a b. (a -> b) -> a -> b
$! String -> Double
forall a. Read a => String -> a
read String
"NaN"
    fromRon Value
_ = String -> ParseResult Double
forall a. String -> ParseResult a
fail String
"Not a floating"
instance ToRon Float where
    toRon :: Float -> Value
toRon Float
x
        | Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
x = Text -> Value
Unit Text
"NaN"
        | Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Float
x = Text -> Value
Unit Text
"inf"
        | Bool
otherwise = Scientific -> Value
Floating (Scientific -> Value) -> (Float -> Scientific) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Scientific
forall a. RealFloat a => a -> Scientific
fromFloatDigits (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ Float
x
instance FromRon Float where
    fromRon :: Value -> ParseResult Float
fromRon (Integral Integer
x) = Float -> ParseResult Float
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> ParseResult Float)
-> (Integer -> Float) -> Integer -> ParseResult Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Float
forall a. Num a => Integer -> a
fromInteger (Integer -> ParseResult Float) -> Integer -> ParseResult Float
forall a b. (a -> b) -> a -> b
$ Integer
x
    fromRon (Floating Scientific
x) = Float -> ParseResult Float
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> ParseResult Float)
-> (Scientific -> Float) -> Scientific -> ParseResult Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Float
forall a. RealFloat a => Scientific -> a
toRealFloat (Scientific -> ParseResult Float)
-> Scientific -> ParseResult Float
forall a b. (a -> b) -> a -> b
$ Scientific
x
    fromRon (Unit Text
"inf") = Float -> ParseResult Float
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> ParseResult Float) -> Float -> ParseResult Float
forall a b. (a -> b) -> a -> b
$! String -> Float
forall a. Read a => String -> a
read String
"Infinity"
    fromRon (Unit Text
"NaN") = Float -> ParseResult Float
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> ParseResult Float) -> Float -> ParseResult Float
forall a b. (a -> b) -> a -> b
$! String -> Float
forall a. Read a => String -> a
read String
"NaN"
    fromRon Value
_ = String -> ParseResult Float
forall a. String -> ParseResult a
fail String
"Not a floating"

instance (ToRon a) => ToRon (Complex a) where
    toRon :: Complex a -> Value
toRon (a
r :+ a
im) = Text -> Vector Value -> Value
Tuple Text
"Complex" ([Value] -> Vector Value
forall a. [a] -> Vector a
Vector.fromList [a -> Value
forall a. ToRon a => a -> Value
toRon a
r, a -> Value
forall a. ToRon a => a -> Value
toRon a
im])
instance (Num a, FromRon a) => FromRon (Complex a) where
    fromRon :: Value -> ParseResult (Complex a)
fromRon v :: Value
v@(Integral Integer
_) = (a -> a -> Complex a
forall a. a -> a -> Complex a
:+ a
0) (a -> Complex a) -> Either String a -> ParseResult (Complex a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either String a
forall a. FromRon a => Value -> ParseResult a
fromRon Value
v
    fromRon v :: Value
v@(Floating Scientific
_) = (a -> a -> Complex a
forall a. a -> a -> Complex a
:+ a
0) (a -> Complex a) -> Either String a -> ParseResult (Complex a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either String a
forall a. FromRon a => Value -> ParseResult a
fromRon Value
v
    fromRon (Tuple Text
name Vector Value
vals) = do
        String -> Bool -> ParseResult ()
guard String
"Incorrect Complex tuple name" (Bool -> ParseResult ()) -> Bool -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" Bool -> Bool -> Bool
|| Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Complex"
        case Vector Value -> [Value]
forall a. Vector a -> [a]
Vector.toList Vector Value
vals of
            [Value
r, Value
im] -> (a -> a -> Complex a)
-> Either String a -> Either String a -> ParseResult (Complex a)
forall a b c.
(a -> b -> c)
-> Either String a -> Either String b -> Either String c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Complex a
forall a. a -> a -> Complex a
(:+) (Value -> Either String a
forall a. FromRon a => Value -> ParseResult a
fromRon Value
r) (Value -> Either String a
forall a. FromRon a => Value -> ParseResult a
fromRon Value
im)
            [Value]
_ -> String -> ParseResult (Complex a)
forall a. String -> ParseResult a
fail String
"Incorrect amount of values in complex coordinates"
    fromRon Value
_ = String -> ParseResult (Complex a)
forall a. String -> ParseResult a
fail String
"Incorrect Complex value"

instance ToRon Char where
    toRon :: Char -> Value
toRon = Char -> Value
Char
instance FromRon Char where
    fromRon :: Value -> ParseResult Char
fromRon (Char Char
x) = Char -> ParseResult Char
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
x
    fromRon Value
_ = String -> ParseResult Char
forall a. String -> ParseResult a
fail String
"Expected Char"

instance ToRon Text where
    toRon :: Text -> Value
toRon = Text -> Value
String
instance FromRon Text where
    fromRon :: Value -> ParseResult Text
fromRon (String Text
x) = Text -> ParseResult Text
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
x
    fromRon Value
_ = String -> ParseResult Text
forall a. String -> ParseResult a
fail String
"Not text"

instance ToRon ByteString where
    toRon :: ByteString -> Value
toRon = Vector Value -> Value
List (Vector Value -> Value)
-> (ByteString -> Vector Value) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Vector Value
forall a. [a] -> Vector a
Vector.fromList ([Value] -> Vector Value)
-> (ByteString -> [Value]) -> ByteString -> Vector Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Value) -> [Word8] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Value
Integral (Integer -> Value) -> (Word8 -> Integer) -> Word8 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Integer
forall a. Integral a => a -> Integer
toInteger) ([Word8] -> [Value])
-> (ByteString -> [Word8]) -> ByteString -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack
instance FromRon ByteString where
    fromRon :: Value -> ParseResult ByteString
fromRon (List Vector Value
bytes) = ([Word8] -> ByteString)
-> Either String [Word8] -> ParseResult ByteString
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word8] -> ByteString
BS.pack (Either String [Word8] -> ParseResult ByteString)
-> (Vector Value -> Either String [Word8])
-> Vector Value
-> ParseResult ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> ParseResult Word8) -> [Value] -> Either String [Word8]
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 Value -> ParseResult Word8
forall {a}. (Bounded a, Integral a) => Value -> ParseResult a
asWord8 ([Value] -> Either String [Word8])
-> (Vector Value -> [Value])
-> Vector Value
-> Either String [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Value -> [Value]
forall a. Vector a -> [a]
Vector.toList (Vector Value -> ParseResult ByteString)
-> Vector Value -> ParseResult ByteString
forall a b. (a -> b) -> a -> b
$ Vector Value
bytes
        where
            asWord8 :: Value -> ParseResult a
asWord8 (Integral Integer
x) = Integer -> ParseResult a
forall a.
(Bounded a, Num a, Integral a) =>
Integer -> ParseResult a
intInRange Integer
x
            asWord8 Value
_ = String -> ParseResult a
forall a. String -> ParseResult a
fail String
"Not a byte in list"
    fromRon (String Text
s) = ByteString -> ParseResult ByteString
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> ParseResult ByteString)
-> (Text -> ByteString) -> Text -> ParseResult ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ParseResult ByteString) -> Text -> ParseResult ByteString
forall a b. (a -> b) -> a -> b
$ Text
s
    fromRon Value
_ = String -> ParseResult ByteString
forall a. String -> ParseResult a
fail String
"Not a bytestring"

instance ToRon Bool where
    toRon :: Bool -> Value
toRon Bool
True = Text -> Value
Unit Text
"true"
    toRon Bool
False = Text -> Value
Unit Text
"false"
instance FromRon Bool where
    fromRon :: Value -> ParseResult Bool
fromRon (Unit Text
name)
        | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"True"  Bool -> Bool -> Bool
|| Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"true"  = Bool -> ParseResult Bool
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"False" Bool -> Bool -> Bool
|| Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"false" = Bool -> ParseResult Bool
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        | Bool
otherwise       = String -> ParseResult Bool
forall a. String -> ParseResult a
fail (String -> ParseResult Bool) -> String -> ParseResult Bool
forall a b. (a -> b) -> a -> b
$ String
"Invalid enum value: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
name
    fromRon Value
_ = String -> ParseResult Bool
forall a. String -> ParseResult a
fail String
"Not a boolean"

instance (ToRon a) => ToRon (Vector.Vector a) where
    toRon :: Vector a -> Value
toRon = Vector Value -> Value
List (Vector Value -> Value)
-> (Vector a -> Vector Value) -> Vector a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> Vector a -> Vector Value
forall a b. (a -> b) -> Vector a -> Vector b
Vector.map a -> Value
forall a. ToRon a => a -> Value
toRon
instance (FromRon a) => FromRon (Vector.Vector a) where
    fromRon :: Value -> ParseResult (Vector a)
fromRon (List Vector Value
xs) = (Value -> Either String a)
-> Vector Value -> ParseResult (Vector 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) -> Vector a -> f (Vector b)
traverse Value -> Either String a
forall a. FromRon a => Value -> ParseResult a
fromRon Vector Value
xs
    fromRon Value
_ = String -> ParseResult (Vector a)
forall a. String -> ParseResult a
fail String
"Not a list"
instance (ToRon a) => ToRon [a] where
    toRon :: [a] -> Value
toRon = Vector Value -> Value
List (Vector Value -> Value) -> ([a] -> Vector Value) -> [a] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Vector Value
forall a. [a] -> Vector a
Vector.fromList ([Value] -> Vector Value)
-> ([a] -> [Value]) -> [a] -> Vector Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map a -> Value
forall a. ToRon a => a -> Value
toRon
instance (FromRon a) => FromRon [a] where
    fromRon :: Value -> ParseResult [a]
fromRon (List Vector Value
xs) = Vector a -> [a]
forall a. Vector a -> [a]
Vector.toList (Vector a -> [a]) -> Either String (Vector a) -> ParseResult [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Either String a)
-> Vector Value -> Either String (Vector 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) -> Vector a -> f (Vector b)
traverse Value -> Either String a
forall a. FromRon a => Value -> ParseResult a
fromRon Vector Value
xs
    fromRon Value
_ = String -> ParseResult [a]
forall a. String -> ParseResult a
fail String
"Not a list"
instance {-# OVERLAPPING #-} ToRon [Char] where
    toRon :: String -> Value
toRon = Text -> Value
String (Text -> Value) -> (String -> Text) -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
instance {-# OVERLAPPING #-} FromRon [Char] where
    fromRon :: Value -> ParseResult String
fromRon = (Text -> String) -> ParseResult Text -> ParseResult String
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
unpack (ParseResult Text -> ParseResult String)
-> (Value -> ParseResult Text) -> Value -> ParseResult String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ParseResult Text
forall a. FromRon a => Value -> ParseResult a
fromRon
instance (ToRon a) => ToRon (NonEmpty a) where
    toRon :: NonEmpty a -> Value
toRon (a
x:|[a]
xs) = [a] -> Value
forall a. ToRon a => a -> Value
toRon ([a] -> Value) -> [a] -> Value
forall a b. (a -> b) -> a -> b
$ a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs
instance (FromRon a) => FromRon (NonEmpty a) where
    fromRon :: Value -> ParseResult (NonEmpty a)
fromRon Value
v = Value -> ParseResult [a]
forall a. FromRon a => Value -> ParseResult a
fromRon Value
v ParseResult [a]
-> ([a] -> ParseResult (NonEmpty a)) -> ParseResult (NonEmpty a)
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [] -> String -> ParseResult (NonEmpty a)
forall a. String -> ParseResult a
fail String
"Expected non-empty list"
        a
x:[a]
xs -> NonEmpty a -> ParseResult (NonEmpty a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty a -> ParseResult (NonEmpty a))
-> NonEmpty a -> ParseResult (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ a
xa -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:|[a]
xs

instance (ToRon k, ToRon v) => ToRon (Map.Map k v) where
    toRon :: Map k v -> Value
toRon = Map Value Value -> Value
Map (Map Value Value -> Value)
-> (Map k v -> Map Value Value) -> Map k v -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Value, Value)] -> Map Value Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Value, Value)] -> Map Value Value)
-> (Map k v -> [(Value, Value)]) -> Map k v -> Map Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> (Value, Value)) -> [(k, v)] -> [(Value, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (k -> Value
forall a. ToRon a => a -> Value
toRon (k -> Value) -> (v -> Value) -> (k, v) -> (Value, Value)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** v -> Value
forall a. ToRon a => a -> Value
toRon) ([(k, v)] -> [(Value, Value)])
-> (Map k v -> [(k, v)]) -> Map k v -> [(Value, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toAscList
instance (FromRon k, FromRon v, Ord k) => FromRon (Map.Map k v) where
    fromRon :: Value -> ParseResult (Map k v)
fromRon (Map Map Value Value
xs) = [(k, v)] -> Map k v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, v)] -> Map k v)
-> Either String [(k, v)] -> ParseResult (Map k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ((Value, Value) -> Either String (k, v))
-> [(Value, Value)] -> Either String [(k, v)]
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 (Value, Value) -> Either String (k, v)
forall {a} {b}.
(FromRon a, FromRon b) =>
(Value, Value) -> Either String (a, b)
tupleFromRon (Map Value Value -> [(Value, Value)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Value Value
xs)
        where tupleFromRon :: (Value, Value) -> Either String (a, b)
tupleFromRon (Value
a, Value
b) = (a -> b -> (a, b))
-> Either String a -> Either String b -> Either String (a, b)
forall a b c.
(a -> b -> c)
-> Either String a -> Either String b -> Either String c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Value -> Either String a
forall a. FromRon a => Value -> ParseResult a
fromRon Value
a) (Value -> Either String b
forall a. FromRon a => Value -> ParseResult a
fromRon Value
b)
    fromRon Value
_ = String -> ParseResult (Map k v)
forall a. String -> ParseResult a
fail String
"Not a map"

instance (ToRon a) => ToRon (Set.Set a) where
    toRon :: Set a -> Value
toRon = [a] -> Value
forall a. ToRon a => a -> Value
toRon ([a] -> Value) -> (Set a -> [a]) -> Set a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toAscList
instance (FromRon a, Ord a) => FromRon (Set.Set a) where
    fromRon :: Value -> ParseResult (Set a)
fromRon = ([a] -> Set a) -> Either String [a] -> ParseResult (Set a)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList (Either String [a] -> ParseResult (Set a))
-> (Value -> Either String [a]) -> Value -> ParseResult (Set a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either String [a]
forall a. FromRon a => Value -> ParseResult a
fromRon
instance (ToRon a) => ToRon (Seq.Seq a) where
    toRon :: Seq a -> Value
toRon = [a] -> Value
forall a. ToRon a => a -> Value
toRon ([a] -> Value) -> (Seq a -> [a]) -> Seq a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq a -> [a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
instance (FromRon a) => FromRon (Seq.Seq a) where
    fromRon :: Value -> ParseResult (Seq a)
fromRon = ([a] -> Seq a) -> Either String [a] -> ParseResult (Seq a)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList (Either String [a] -> ParseResult (Seq a))
-> (Value -> Either String [a]) -> Value -> ParseResult (Seq a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either String [a]
forall a. FromRon a => Value -> ParseResult a
fromRon

instance ToRon () where
    toRon :: () -> Value
toRon () = Text -> Value
Unit Text
""
instance FromRon () where
    fromRon :: Value -> ParseResult ()
fromRon (Unit Text
name)
        | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
""   = () -> ParseResult ()
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise    = String -> ParseResult ()
forall a. String -> ParseResult a
fail String
"Not a unit enum value"
    fromRon Value
_ = String -> ParseResult ()
forall a. String -> ParseResult a
fail String
"Not a unit"

instance (ToRon a) => ToRon (Maybe a) where
    toRon :: Maybe a -> Value
toRon (Just a
x) = Text -> Vector Value -> Value
Tuple Text
"Some" (Value -> Vector Value
forall a. a -> Vector a
Vector.singleton (Value -> Vector Value) -> Value -> Vector Value
forall a b. (a -> b) -> a -> b
$ a -> Value
forall a. ToRon a => a -> Value
toRon a
x)
    toRon Maybe a
Nothing = Text -> Value
Unit Text
"None"
instance (FromRon a) => FromRon (Maybe a) where
    fromRon :: Value -> ParseResult (Maybe a)
fromRon (Tuple Text
name Vector Value
xs)
        | (Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Just" Bool -> Bool -> Bool
|| Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Some") Bool -> Bool -> Bool
&& Vector Value -> Int
forall a. Vector a -> Int
Vector.length Vector Value
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
            = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either String a -> ParseResult (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either String a
forall a. FromRon a => Value -> ParseResult a
fromRon (Vector Value -> Value
forall a. Vector a -> a
Vector.unsafeHead Vector Value
xs)
        | Bool
otherwise = String -> ParseResult (Maybe a)
forall a. String -> ParseResult a
fail String
"Not a Maybe enum"
    fromRon (Unit Text
name)
        | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Nothing" Bool -> Bool -> Bool
|| Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"None" = Maybe a -> ParseResult (Maybe a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        | Bool
otherwise = String -> ParseResult (Maybe a)
forall a. String -> ParseResult a
fail (String -> ParseResult (Maybe a))
-> String -> ParseResult (Maybe a)
forall a b. (a -> b) -> a -> b
$ String
"Incorrect Maybe name: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
name
    fromRon Value
_ = String -> ParseResult (Maybe a)
forall a. String -> ParseResult a
fail String
"Not a named tuple or unit"

instance (ToRon a, ToRon b) => ToRon (Either a b) where
    toRon :: Either a b -> Value
toRon (Left a
x) = Text -> Vector Value -> Value
Tuple Text
"Left" (Value -> Vector Value
forall a. a -> Vector a
Vector.singleton (Value -> Vector Value) -> Value -> Vector Value
forall a b. (a -> b) -> a -> b
$ a -> Value
forall a. ToRon a => a -> Value
toRon a
x)
    toRon (Right b
x) = Text -> Vector Value -> Value
Tuple Text
"Right" (Value -> Vector Value
forall a. a -> Vector a
Vector.singleton (Value -> Vector Value) -> Value -> Vector Value
forall a b. (a -> b) -> a -> b
$ b -> Value
forall a. ToRon a => a -> Value
toRon b
x)
instance (FromRon a, FromRon b) => FromRon (Either a b) where
    fromRon :: Value -> ParseResult (Either a b)
fromRon (Tuple Text
name Vector Value
xs)
        | Vector Value -> Int
forall a. Vector a -> Int
Vector.length Vector Value
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1  =
            if | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Left"  -> a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> Either String a -> ParseResult (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either String a
forall a. FromRon a => Value -> ParseResult a
fromRon (Vector Value -> Value
forall a. Vector a -> a
Vector.unsafeHead Vector Value
xs)
               | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Right" -> b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> Either String b -> ParseResult (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either String b
forall a. FromRon a => Value -> ParseResult a
fromRon (Vector Value -> Value
forall a. Vector a -> a
Vector.unsafeHead Vector Value
xs)
               | Bool
otherwise -> String -> ParseResult (Either a b)
forall a. String -> ParseResult a
fail String
"Not an Either enum"
        | Bool
otherwise = String -> ParseResult (Either a b)
forall a. String -> ParseResult a
fail String
"Incorrect amount of arguments to Either"
    fromRon Value
_ = String -> ParseResult (Either a b)
forall a. String -> ParseResult a
fail String
"Not an Either value"

instance (ToRon a1, ToRon a2) => ToRon (a1, a2) where
    toRon :: (a1, a2) -> Value
toRon (a1
a1, a2
a2) = Text -> Vector Value -> Value
Tuple Text
"" (Vector Value -> Value)
-> ([Value] -> Vector Value) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Vector Value
forall a. [a] -> Vector a
Vector.fromList ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ [a1 -> Value
forall a. ToRon a => a -> Value
toRon a1
a1, a2 -> Value
forall a. ToRon a => a -> Value
toRon a2
a2]

instance (FromRon a1, FromRon a2) => FromRon (a1, a2) where
    fromRon :: Value -> ParseResult (a1, a2)
fromRon (Tuple Text
name Vector Value
xs)
        | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" = case Vector Value -> [Value]
forall a. Vector a -> [a]
Vector.toList Vector Value
xs of
            [Value
a1, Value
a2] -> (a1 -> a2 -> (a1, a2))
-> Either String a1 -> Either String a2 -> ParseResult (a1, a2)
forall a b c.
(a -> b -> c)
-> Either String a -> Either String b -> Either String c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Value -> Either String a1
forall a. FromRon a => Value -> ParseResult a
fromRon Value
a1) (Value -> Either String a2
forall a. FromRon a => Value -> ParseResult a
fromRon Value
a2)
            [Value]
_ -> String -> ParseResult (a1, a2)
forall a. String -> ParseResult a
fail String
"Incorrect amount of tuple values"
        | Bool
otherwise = String -> ParseResult (a1, a2)
forall a. String -> ParseResult a
fail String
"Incorrect tuple name"
    fromRon Value
_ = String -> ParseResult (a1, a2)
forall a. String -> ParseResult a
fail String
"Not a tuple"


--- Generic instance

-- | Part of 'RonSettings' that applies to both encoding and decoding, and
-- separately
data RonFlags = RonFlags
    { RonFlags -> Bool
implicitSome :: !Bool
    -- ^ Like ron-rs's @implicit_some@. When set to True, 'Nothing' in record
    -- fields is represented by omission of the field
    , RonFlags -> Bool
skipSingleConstructor :: !Bool
    -- ^ When a datatype has a single constructor, encoding will omit it and
    -- decoding will ignore it missing, turning the representation into a tuple
    -- or an anonymous record.
    } deriving (RonFlags -> RonFlags -> Bool
(RonFlags -> RonFlags -> Bool)
-> (RonFlags -> RonFlags -> Bool) -> Eq RonFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RonFlags -> RonFlags -> Bool
== :: RonFlags -> RonFlags -> Bool
$c/= :: RonFlags -> RonFlags -> Bool
/= :: RonFlags -> RonFlags -> Bool
Eq, Int -> RonFlags -> String -> String
[RonFlags] -> String -> String
RonFlags -> String
(Int -> RonFlags -> String -> String)
-> (RonFlags -> String)
-> ([RonFlags] -> String -> String)
-> Show RonFlags
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> RonFlags -> String -> String
showsPrec :: Int -> RonFlags -> String -> String
$cshow :: RonFlags -> String
show :: RonFlags -> String
$cshowList :: [RonFlags] -> String -> String
showList :: [RonFlags] -> String -> String
Show)

-- | Settings for use with 'Generic' RON encoding/decoding
data RonSettings = RonSettings
    { RonSettings -> String -> String
fieldModifier :: !(String -> String)
    -- ^ Every field will be renamed using the supplied function
    , RonSettings -> String -> String
constructorModifier :: !(String -> String)
    -- ^ Every constructor will be renamed using the supplied function
    , RonSettings -> RonFlags
decodeFlags :: !RonFlags
    -- ^ Options that apply to encoding separately from decoding
    , RonSettings -> RonFlags
encodeFlags :: !RonFlags
    -- ^ Options that apply to decoding separately from encoding
    }

data SumContext = SumContext
    { SumContext -> Bool
isSingleConstructor :: Bool
    , SumContext -> String
sumTypeName :: String
    } deriving (SumContext -> SumContext -> Bool
(SumContext -> SumContext -> Bool)
-> (SumContext -> SumContext -> Bool) -> Eq SumContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SumContext -> SumContext -> Bool
== :: SumContext -> SumContext -> Bool
$c/= :: SumContext -> SumContext -> Bool
/= :: SumContext -> SumContext -> Bool
Eq, Int -> SumContext -> String -> String
[SumContext] -> String -> String
SumContext -> String
(Int -> SumContext -> String -> String)
-> (SumContext -> String)
-> ([SumContext] -> String -> String)
-> Show SumContext
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SumContext -> String -> String
showsPrec :: Int -> SumContext -> String -> String
$cshow :: SumContext -> String
show :: SumContext -> String
$cshowList :: [SumContext] -> String -> String
showList :: [SumContext] -> String -> String
Show)

data ProductContext = ProductContext
    { ProductContext -> String
prodTypeName :: String
    , ProductContext -> String
constructorName :: String
    } deriving (ProductContext -> ProductContext -> Bool
(ProductContext -> ProductContext -> Bool)
-> (ProductContext -> ProductContext -> Bool) -> Eq ProductContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProductContext -> ProductContext -> Bool
== :: ProductContext -> ProductContext -> Bool
$c/= :: ProductContext -> ProductContext -> Bool
/= :: ProductContext -> ProductContext -> Bool
Eq, Int -> ProductContext -> String -> String
[ProductContext] -> String -> String
ProductContext -> String
(Int -> ProductContext -> String -> String)
-> (ProductContext -> String)
-> ([ProductContext] -> String -> String)
-> Show ProductContext
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ProductContext -> String -> String
showsPrec :: Int -> ProductContext -> String -> String
$cshow :: ProductContext -> String
show :: ProductContext -> String
$cshowList :: [ProductContext] -> String -> String
showList :: [ProductContext] -> String -> String
Show)

-- | Encode ron using 'Generic' instance and provided 'RonSettings'.
--
-- With generic encoding sums are turned into sums, records into records, and
-- multi-param constructors into tuples.
toRonGeneric :: (Generic a, GToRon (Rep a)) => RonSettings -> a -> Value
toRonGeneric :: forall a. (Generic a, GToRon (Rep a)) => RonSettings -> a -> Value
toRonGeneric RonSettings
conf = RonSettings -> Rep a Any -> Value
forall a. RonSettings -> Rep a a -> Value
forall (f :: * -> *) a. GToRon f => RonSettings -> f a -> Value
toRonG RonSettings
conf (Rep a Any -> Value) -> (a -> Rep a Any) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

-- | Values are expected to exactly conform: all fields should have the same
-- name, all constructors should be present, no @Some@ omission
strictRonSettings :: RonSettings
strictRonSettings :: RonSettings
strictRonSettings = RonSettings
    { fieldModifier :: String -> String
fieldModifier = String -> String
forall a. a -> a
id
    , constructorModifier :: String -> String
constructorModifier = String -> String
forall a. a -> a
id
    , decodeFlags :: RonFlags
decodeFlags = RonFlags
        { implicitSome :: Bool
implicitSome = Bool
False
        , skipSingleConstructor :: Bool
skipSingleConstructor = Bool
False
        }
    , encodeFlags :: RonFlags
encodeFlags = RonFlags
        { implicitSome :: Bool
implicitSome = Bool
False
        , skipSingleConstructor :: Bool
skipSingleConstructor = Bool
False
        }
    }

-- | Relaxes 'strictRonSettings' on constructor omission and implicitSome when
-- decoding, but encodes in the same strict way
laxRonSettings :: RonSettings
laxRonSettings :: RonSettings
laxRonSettings = RonSettings
    { fieldModifier :: String -> String
fieldModifier = String -> String
forall a. a -> a
id
    , constructorModifier :: String -> String
constructorModifier = String -> String
forall a. a -> a
id
    , decodeFlags :: RonFlags
decodeFlags = RonFlags
        { implicitSome :: Bool
implicitSome = Bool
True
        , skipSingleConstructor :: Bool
skipSingleConstructor = Bool
True
        }
    , encodeFlags :: RonFlags
encodeFlags = RonFlags
        { implicitSome :: Bool
implicitSome = Bool
False
        , skipSingleConstructor :: Bool
skipSingleConstructor = Bool
False
        }
    }

toRonDefault :: (Generic a, GToRon (Rep a)) => a -> Value
toRonDefault :: forall a. (Generic a, GToRon (Rep a)) => a -> Value
toRonDefault = RonSettings -> a -> Value
forall a. (Generic a, GToRon (Rep a)) => RonSettings -> a -> Value
toRonGeneric RonSettings
laxRonSettings

-- | Internal class for converting to Ron. You might need it if you're writing
-- you own generic combinators
class GToRon f where
    toRonG :: RonSettings -> f a -> Value

class GToRonSum f where
    toRonSum :: RonSettings -> SumContext -> f a -> Value
class GToRonProduct f where
    toRonProduct
        :: RonSettings -> ProductContext -> f a -> Either (Vector Value) (Map Text Value)
class GToRonRec f where
    toRonRec :: RonSettings -> f a -> Value

instance (Datatype d, GToRonSum f) => GToRon (M1 D d f) where
    toRonG :: forall a. RonSettings -> M1 D d f a -> Value
toRonG RonSettings
conf (M1 f a
x) = RonSettings -> SumContext -> f a -> Value
forall a. RonSettings -> SumContext -> f a -> Value
forall (f :: * -> *) a.
GToRonSum f =>
RonSettings -> SumContext -> f a -> Value
toRonSum RonSettings
conf SumContext
cont f a
x
        where cont :: SumContext
cont = SumContext
                { isSingleConstructor :: Bool
isSingleConstructor = Bool
True
                , sumTypeName :: String
sumTypeName = Any d f Any -> String
forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t d f a -> String
datatypeName (t d f a
forall a. HasCallStack => a
forall {t :: Meta -> (* -> *) -> * -> *} {a}. t d f a
undefined :: t d f a)
                }

instance GToRonSum V1 where
    toRonSum :: forall a. RonSettings -> SumContext -> V1 a -> Value
toRonSum RonSettings
_ SumContext
_ V1 a
x = case V1 a
x of {}

instance (Constructor c, GToRonProduct f) => GToRonSum (M1 C c f) where
    toRonSum :: forall a. RonSettings -> SumContext -> M1 C c f a -> Value
toRonSum RonSettings
conf SumContext
cont (M1 f a
x) =
        let con :: t c f a
con = t c f a
forall a. HasCallStack => a
forall {t :: Meta -> (* -> *) -> * -> *} {a}. t c f a
undefined :: t c f a
            name :: Text
name = if SumContext -> Bool
isSingleConstructor SumContext
cont
                        Bool -> Bool -> Bool
&& RonFlags -> Bool
skipSingleConstructor (RonSettings -> RonFlags
encodeFlags RonSettings
conf)
                    then Text
""
                    else String -> Text
pack (String -> Text) -> (Any c f Any -> String) -> Any c f Any -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any c f Any -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName (Any c f Any -> Text) -> Any c f Any -> Text
forall a b. (a -> b) -> a -> b
$ Any c f Any
forall {t :: Meta -> (* -> *) -> * -> *} {a}. t c f a
con
            cont' :: ProductContext
cont' = ProductContext
                { prodTypeName :: String
prodTypeName = SumContext -> String
sumTypeName SumContext
cont
                , constructorName :: String
constructorName = Text -> String
unpack Text
name
                }
            xs :: Either (Vector Value) (Map Text Value)
xs = RonSettings
-> ProductContext -> f a -> Either (Vector Value) (Map Text Value)
forall a.
RonSettings
-> ProductContext -> f a -> Either (Vector Value) (Map Text Value)
forall (f :: * -> *) a.
GToRonProduct f =>
RonSettings
-> ProductContext -> f a -> Either (Vector Value) (Map Text Value)
toRonProduct RonSettings
conf ProductContext
cont' f a
x
        in case (Either (Vector Value) (Map Text Value)
xs, Any c f Any -> Bool
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> Bool
conIsRecord Any c f Any
forall {t :: Meta -> (* -> *) -> * -> *} {a}. t c f a
con) of
            (Right Map Text Value
xs', Bool
True) -> Text -> Map Text Value -> Value
Record Text
name Map Text Value
xs'
            (Left Vector Value
xs', Bool
False) -> Text -> Vector Value -> Value
Tuple Text
name Vector Value
xs'
            (Right Map Text Value
xs', Bool
_) | Map Text Value -> Bool
forall a. Map Text a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text Value
xs' -> Text -> Value
Unit Text
name
            (Left Vector Value
xs', Bool
_) | Vector Value -> Bool
forall a. Vector a -> Bool
Vector.null Vector Value
xs' -> Text -> Value
Unit Text
name
            (Either (Vector Value) (Map Text Value), Bool)
_ -> String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"Bad product: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
128 (Either (Vector Value) (Map Text Value) -> String
forall a. Show a => a -> String
show Either (Vector Value) (Map Text Value)
xs)

instance (GToRonSum fl, GToRonSum fr) => GToRonSum (fl :+: fr) where
    toRonSum :: forall a. RonSettings -> SumContext -> (:+:) fl fr a -> Value
toRonSum RonSettings
conf SumContext
cont (L1 fl a
x) = RonSettings -> SumContext -> fl a -> Value
forall a. RonSettings -> SumContext -> fl a -> Value
forall (f :: * -> *) a.
GToRonSum f =>
RonSettings -> SumContext -> f a -> Value
toRonSum RonSettings
conf SumContext
cont' fl a
x
        where cont' :: SumContext
cont' = SumContext
cont
                {isSingleConstructor = False}
    toRonSum RonSettings
conf SumContext
cont (R1 fr a
x) = RonSettings -> SumContext -> fr a -> Value
forall a. RonSettings -> SumContext -> fr a -> Value
forall (f :: * -> *) a.
GToRonSum f =>
RonSettings -> SumContext -> f a -> Value
toRonSum RonSettings
conf SumContext
cont' fr a
x
        where cont' :: SumContext
cont' = SumContext
cont
                {isSingleConstructor = False}

instance GToRonProduct U1 where
    toRonProduct :: forall a.
RonSettings
-> ProductContext -> U1 a -> Either (Vector Value) (Map Text Value)
toRonProduct RonSettings
_ ProductContext
_ U1 a
U1 = Vector Value -> Either (Vector Value) (Map Text Value)
forall a b. a -> Either a b
Left Vector Value
forall a. Vector a
Vector.empty

instance {-# OVERLAPPING #-} (Selector s, ToRon c)
    => GToRonProduct (M1 S s (K1 R (Maybe c))) where
    toRonProduct :: forall a.
RonSettings
-> ProductContext
-> M1 S s (K1 R (Maybe c)) a
-> Either (Vector Value) (Map Text Value)
toRonProduct RonSettings
conf ProductContext
_cont (M1 (K1 Maybe c
x)) =
        let field :: String
field = Any s (K1 R (Maybe c)) Any -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (t s (K1 R (Maybe c)) a
forall a. HasCallStack => a
forall {t :: Meta -> (* -> *) -> * -> *} {a}.
t s (K1 R (Maybe c)) a
undefined :: t s (K1 R (Maybe c)) a)
        in case Maybe c
x of
            Maybe c
Nothing | RonFlags -> Bool
implicitSome (RonFlags -> Bool)
-> (RonSettings -> RonFlags) -> RonSettings -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RonSettings -> RonFlags
encodeFlags (RonSettings -> Bool) -> RonSettings -> Bool
forall a b. (a -> b) -> a -> b
$ RonSettings
conf ->
                if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
field
                    then Vector Value -> Either (Vector Value) (Map Text Value)
forall a b. a -> Either a b
Left (Vector Value -> Either (Vector Value) (Map Text Value))
-> (Maybe () -> Vector Value)
-> Maybe ()
-> Either (Vector Value) (Map Text Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Vector Value
forall a. a -> Vector a
Vector.singleton (Value -> Vector Value)
-> (Maybe () -> Value) -> Maybe () -> Vector Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe () -> Value
forall a. ToRon a => a -> Value
toRon (Maybe () -> Either (Vector Value) (Map Text Value))
-> Maybe () -> Either (Vector Value) (Map Text Value)
forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing @()
                    else Map Text Value -> Either (Vector Value) (Map Text Value)
forall a b. b -> Either a b
Right Map Text Value
forall k a. Map k a
Map.empty
            Just c
x' | RonFlags -> Bool
implicitSome (RonFlags -> Bool)
-> (RonSettings -> RonFlags) -> RonSettings -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RonSettings -> RonFlags
encodeFlags (RonSettings -> Bool) -> RonSettings -> Bool
forall a b. (a -> b) -> a -> b
$ RonSettings
conf ->
                if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
field
                    then Vector Value -> Either (Vector Value) (Map Text Value)
forall a b. a -> Either a b
Left (Vector Value -> Either (Vector Value) (Map Text Value))
-> (c -> Vector Value)
-> c
-> Either (Vector Value) (Map Text Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Vector Value
forall a. a -> Vector a
Vector.singleton (Value -> Vector Value) -> (c -> Value) -> c -> Vector Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Value
forall a. ToRon a => a -> Value
toRon (c -> Either (Vector Value) (Map Text Value))
-> c -> Either (Vector Value) (Map Text Value)
forall a b. (a -> b) -> a -> b
$ c
x'
                    else
                        let field' :: Text
field' = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ RonSettings -> String -> String
fieldModifier RonSettings
conf String
field
                            value :: Value
value = c -> Value
forall a. ToRon a => a -> Value
toRon c
x'
                        in Map Text Value -> Either (Vector Value) (Map Text Value)
forall a b. b -> Either a b
Right (Map Text Value -> Either (Vector Value) (Map Text Value))
-> Map Text Value -> Either (Vector Value) (Map Text Value)
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Map Text Value
forall k a. k -> a -> Map k a
Map.singleton Text
field' Value
value
            Maybe c
x'
                | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
field -> Vector Value -> Either (Vector Value) (Map Text Value)
forall a b. a -> Either a b
Left (Vector Value -> Either (Vector Value) (Map Text Value))
-> (Maybe c -> Vector Value)
-> Maybe c
-> Either (Vector Value) (Map Text Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Vector Value
forall a. a -> Vector a
Vector.singleton (Value -> Vector Value)
-> (Maybe c -> Value) -> Maybe c -> Vector Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe c -> Value
forall a. ToRon a => a -> Value
toRon (Maybe c -> Either (Vector Value) (Map Text Value))
-> Maybe c -> Either (Vector Value) (Map Text Value)
forall a b. (a -> b) -> a -> b
$ Maybe c
x'
                | Bool
otherwise ->
                    let field' :: Text
field' = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ RonSettings -> String -> String
fieldModifier RonSettings
conf String
field
                    in Map Text Value -> Either (Vector Value) (Map Text Value)
forall a b. b -> Either a b
Right (Map Text Value -> Either (Vector Value) (Map Text Value))
-> (Value -> Map Text Value)
-> Value
-> Either (Vector Value) (Map Text Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value -> Map Text Value
forall k a. k -> a -> Map k a
Map.singleton Text
field' (Value -> Either (Vector Value) (Map Text Value))
-> Value -> Either (Vector Value) (Map Text Value)
forall a b. (a -> b) -> a -> b
$ Maybe c -> Value
forall a. ToRon a => a -> Value
toRon Maybe c
x'

instance (Selector s, GToRonRec f) => GToRonProduct (M1 S s f) where
    toRonProduct :: forall a.
RonSettings
-> ProductContext
-> M1 S s f a
-> Either (Vector Value) (Map Text Value)
toRonProduct RonSettings
conf ProductContext
_cont (M1 f a
x) =
        let field :: String
field = Any s f Any -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (t s f a
forall a. HasCallStack => a
forall {t :: Meta -> (* -> *) -> * -> *} {a}. t s f a
undefined :: t s f a)
            value :: Value
value = RonSettings -> f a -> Value
forall a. RonSettings -> f a -> Value
forall (f :: * -> *) a. GToRonRec f => RonSettings -> f a -> Value
toRonRec RonSettings
conf f a
x
        in case String
field of
            String
"" -> Vector Value -> Either (Vector Value) (Map Text Value)
forall a b. a -> Either a b
Left (Vector Value -> Either (Vector Value) (Map Text Value))
-> (Value -> Vector Value)
-> Value
-> Either (Vector Value) (Map Text Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Vector Value
forall a. a -> Vector a
Vector.singleton (Value -> Either (Vector Value) (Map Text Value))
-> Value -> Either (Vector Value) (Map Text Value)
forall a b. (a -> b) -> a -> b
$ Value
value
            String
_field ->
                let field' :: Text
field' = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ RonSettings -> String -> String
fieldModifier RonSettings
conf String
field
                in Map Text Value -> Either (Vector Value) (Map Text Value)
forall a b. b -> Either a b
Right (Map Text Value -> Either (Vector Value) (Map Text Value))
-> Map Text Value -> Either (Vector Value) (Map Text Value)
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Map Text Value
forall k a. k -> a -> Map k a
Map.singleton Text
field' Value
value

instance (GToRonProduct pl, GToRonProduct pr)
    => GToRonProduct (pl :*: pr) where
    toRonProduct :: forall a.
RonSettings
-> ProductContext
-> (:*:) pl pr a
-> Either (Vector Value) (Map Text Value)
toRonProduct RonSettings
conf ProductContext
cont (pl a
x :*: pr a
y) =
        case (RonSettings
-> ProductContext -> pl a -> Either (Vector Value) (Map Text Value)
forall a.
RonSettings
-> ProductContext -> pl a -> Either (Vector Value) (Map Text Value)
forall (f :: * -> *) a.
GToRonProduct f =>
RonSettings
-> ProductContext -> f a -> Either (Vector Value) (Map Text Value)
toRonProduct RonSettings
conf ProductContext
cont pl a
x, RonSettings
-> ProductContext -> pr a -> Either (Vector Value) (Map Text Value)
forall a.
RonSettings
-> ProductContext -> pr a -> Either (Vector Value) (Map Text Value)
forall (f :: * -> *) a.
GToRonProduct f =>
RonSettings
-> ProductContext -> f a -> Either (Vector Value) (Map Text Value)
toRonProduct RonSettings
conf ProductContext
cont pr a
y) of
            (Left Vector Value
xs, Left Vector Value
ys) -> Vector Value -> Either (Vector Value) (Map Text Value)
forall a b. a -> Either a b
Left (Vector Value -> Either (Vector Value) (Map Text Value))
-> Vector Value -> Either (Vector Value) (Map Text Value)
forall a b. (a -> b) -> a -> b
$ Vector Value
xs Vector Value -> Vector Value -> Vector Value
forall a. Semigroup a => a -> a -> a
<> Vector Value
ys
            (Right Map Text Value
xs, Right Map Text Value
ys) -> Map Text Value -> Either (Vector Value) (Map Text Value)
forall a b. b -> Either a b
Right (Map Text Value -> Either (Vector Value) (Map Text Value))
-> Map Text Value -> Either (Vector Value) (Map Text Value)
forall a b. (a -> b) -> a -> b
$ Map Text Value -> Map Text Value -> Map Text Value
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Text Value
xs Map Text Value
ys
            (Either (Vector Value) (Map Text Value),
 Either (Vector Value) (Map Text Value))
_ -> String -> Either (Vector Value) (Map Text Value)
forall a. HasCallStack => String -> a
error String
"Incompatible product branches"

instance ToRon c => GToRonRec (K1 R c) where
    toRonRec :: forall a. RonSettings -> K1 R c a -> Value
toRonRec RonSettings
_ (K1 c
x) = c -> Value
forall a. ToRon a => a -> Value
toRon c
x


-- | Decode ron using 'Generic' instance and provided 'RonSettings'
--
-- With generic encoding sums are turned into sums, records into records, and
-- multi-param constructors into tuples.
fromRonGeneric
    :: (Generic a, GFromRon (Rep a)) => RonSettings -> Value -> ParseResult a
fromRonGeneric :: forall a.
(Generic a, GFromRon (Rep a)) =>
RonSettings -> Value -> ParseResult a
fromRonGeneric RonSettings
conf = (Rep a Any -> a) -> Either String (Rep a Any) -> Either String a
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Either String (Rep a Any) -> Either String a)
-> (Value -> Either String (Rep a Any)) -> Value -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RonSettings -> Value -> Either String (Rep a Any)
forall a. RonSettings -> Value -> ParseResult (Rep a a)
forall (f :: * -> *) a.
GFromRon f =>
RonSettings -> Value -> ParseResult (f a)
fromRonG RonSettings
conf

fromRonDefault :: (Generic a, GFromRon (Rep a)) => Value -> ParseResult a
fromRonDefault :: forall a. (Generic a, GFromRon (Rep a)) => Value -> ParseResult a
fromRonDefault = RonSettings -> Value -> ParseResult a
forall a.
(Generic a, GFromRon (Rep a)) =>
RonSettings -> Value -> ParseResult a
fromRonGeneric RonSettings
laxRonSettings

-- | Internal class for converting from Ron. You might need it if you're
-- writing you own generic combinators
class GFromRon f where
    fromRonG :: RonSettings -> Value -> ParseResult (f a)

class GFromRonSum f where
    fromRonSum :: RonSettings -> SumContext -> Value -> ParseResult (f a)
class GFromRonProduct f where
    fromRonProduct
        :: RonSettings
        -> ProductContext
        -> Either (Vector Value) (Map Text Value)
        -> ParseResult (f a)
class GFromRonRec f where
    fromRonRec :: RonSettings -> Value -> ParseResult (f a)

instance (Datatype d, GFromRonSum f) => GFromRon (M1 D d f) where
    fromRonG :: forall a. RonSettings -> Value -> ParseResult (M1 D d f a)
fromRonG RonSettings
conf Value
x = f a -> M1 D d f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 D d f a)
-> Either String (f a) -> Either String (M1 D d f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RonSettings -> SumContext -> Value -> Either String (f a)
forall a. RonSettings -> SumContext -> Value -> ParseResult (f a)
forall (f :: * -> *) a.
GFromRonSum f =>
RonSettings -> SumContext -> Value -> ParseResult (f a)
fromRonSum RonSettings
conf SumContext
cont Value
x
        where cont :: SumContext
cont = SumContext
                { isSingleConstructor :: Bool
isSingleConstructor = Bool
True
                , sumTypeName :: String
sumTypeName = Any d f Any -> String
forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t d f a -> String
datatypeName (t d f a
forall a. HasCallStack => a
forall {t :: Meta -> (* -> *) -> * -> *} {a}. t d f a
undefined :: t d f a)
                }

instance (Constructor c, GFromRonProduct f) => GFromRonSum (M1 C c f) where
    fromRonSum :: forall a.
RonSettings -> SumContext -> Value -> ParseResult (M1 C c f a)
fromRonSum RonSettings
conf SumContext
cont Value
x =
        f a -> M1 C c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 C c f a)
-> Either String (f a) -> Either String (M1 C c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Value
x of
            Unit Text
n | Text
name Text -> Text -> Bool
forall {a}. (Eq a, IsString a) => a -> a -> Bool
`matches` Text
n
                        -> RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> Either String (f a)
forall a.
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (f a)
forall (f :: * -> *) a.
GFromRonProduct f =>
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (f a)
fromRonProduct RonSettings
conf ProductContext
cont' (Either (Vector Value) (Map Text Value) -> Either String (f a))
-> Either (Vector Value) (Map Text Value) -> Either String (f a)
forall a b. (a -> b) -> a -> b
$ Vector Value -> Either (Vector Value) (Map Text Value)
forall a b. a -> Either a b
Left Vector Value
forall a. Vector a
Vector.empty
                   | Bool
otherwise -> String -> Either String (f a)
forall a. String -> ParseResult a
fail String
incorrectConstructor
            Tuple Text
n Vector Value
xs | Text
name Text -> Text -> Bool
forall {a}. (Eq a, IsString a) => a -> a -> Bool
`matches` Text
n -> RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> Either String (f a)
forall a.
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (f a)
forall (f :: * -> *) a.
GFromRonProduct f =>
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (f a)
fromRonProduct RonSettings
conf ProductContext
cont' (Either (Vector Value) (Map Text Value) -> Either String (f a))
-> Either (Vector Value) (Map Text Value) -> Either String (f a)
forall a b. (a -> b) -> a -> b
$ Vector Value -> Either (Vector Value) (Map Text Value)
forall a b. a -> Either a b
Left Vector Value
xs
                       | Bool
otherwise -> String -> Either String (f a)
forall a. String -> ParseResult a
fail String
incorrectConstructor
            Record Text
n Map Text Value
xs | Text
name Text -> Text -> Bool
forall {a}. (Eq a, IsString a) => a -> a -> Bool
`matches` Text
n -> RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> Either String (f a)
forall a.
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (f a)
forall (f :: * -> *) a.
GFromRonProduct f =>
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (f a)
fromRonProduct RonSettings
conf ProductContext
cont' (Either (Vector Value) (Map Text Value) -> Either String (f a))
-> Either (Vector Value) (Map Text Value) -> Either String (f a)
forall a b. (a -> b) -> a -> b
$ Map Text Value -> Either (Vector Value) (Map Text Value)
forall a b. b -> Either a b
Right Map Text Value
xs
                        | Bool
otherwise -> String -> Either String (f a)
forall a. String -> ParseResult a
fail String
incorrectConstructor
            Value
_ -> String -> Either String (f a)
forall a. String -> ParseResult a
fail (String -> Either String (f a)) -> String -> Either String (f a)
forall a b. (a -> b) -> a -> b
$ String
"Incorrect value for type " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SumContext -> String
sumTypeName SumContext
cont
        where
            con :: t c f a
con = t c f a
forall a. HasCallStack => a
forall {t :: Meta -> (* -> *) -> * -> *} {a}. t c f a
undefined :: t c f a
            name :: Text
name = String -> Text
pack (String -> Text) -> (Any c f Any -> String) -> Any c f Any -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any c f Any -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName (Any c f Any -> Text) -> Any c f Any -> Text
forall a b. (a -> b) -> a -> b
$ Any c f Any
forall {t :: Meta -> (* -> *) -> * -> *} {a}. t c f a
con
            matches :: a -> a -> Bool
matches a
target a
ron =
                a
ron a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
target
                Bool -> Bool -> Bool
|| a
ron a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
""
                    Bool -> Bool -> Bool
&& SumContext -> Bool
isSingleConstructor SumContext
cont
                    Bool -> Bool -> Bool
&& RonFlags -> Bool
skipSingleConstructor (RonSettings -> RonFlags
decodeFlags RonSettings
conf)
            incorrectConstructor :: String
incorrectConstructor = String
"Incorrect constructor " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
constructorName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" for type " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SumContext -> String
sumTypeName SumContext
cont
            constructorName :: String
constructorName = case Text -> String
unpack Text
name of
                String
"" -> String
"<UNNAMED>"
                String
n -> String
n
            cont' :: ProductContext
cont' = ProductContext
                { prodTypeName :: String
prodTypeName = SumContext -> String
sumTypeName SumContext
cont
                , String
constructorName :: String
constructorName :: String
constructorName
                }

instance (GFromRonSum fl, GFromRonSum fr) => GFromRonSum (fl :+: fr) where
    fromRonSum :: forall a.
RonSettings -> SumContext -> Value -> ParseResult ((:+:) fl fr a)
fromRonSum RonSettings
conf SumContext
cont Value
x =
        (fl a -> (:+:) fl fr a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (fl a -> (:+:) fl fr a)
-> Either String (fl a) -> Either String ((:+:) fl fr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RonSettings -> SumContext -> Value -> Either String (fl a)
forall a. RonSettings -> SumContext -> Value -> ParseResult (fl a)
forall (f :: * -> *) a.
GFromRonSum f =>
RonSettings -> SumContext -> Value -> ParseResult (f a)
fromRonSum RonSettings
conf SumContext
cont' Value
x) Either String ((:+:) fl fr a)
-> Either String ((:+:) fl fr a) -> Either String ((:+:) fl fr a)
forall a. ParseResult a -> ParseResult a -> ParseResult a
<<|>> (fr a -> (:+:) fl fr a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (fr a -> (:+:) fl fr a)
-> Either String (fr a) -> Either String ((:+:) fl fr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RonSettings -> SumContext -> Value -> Either String (fr a)
forall a. RonSettings -> SumContext -> Value -> ParseResult (fr a)
forall (f :: * -> *) a.
GFromRonSum f =>
RonSettings -> SumContext -> Value -> ParseResult (f a)
fromRonSum RonSettings
conf SumContext
cont' Value
x)
        where cont' :: SumContext
cont' = SumContext
cont
                { isSingleConstructor = False }

instance GFromRonProduct U1 where
    fromRonProduct :: forall a.
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (U1 a)
fromRonProduct RonSettings
_ ProductContext
_ (Left Vector Value
xs) | Vector Value -> Bool
forall a. Vector a -> Bool
Vector.null Vector Value
xs  = U1 a -> Either String (U1 a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
    fromRonProduct RonSettings
_ ProductContext
_ (Right Map Text Value
xs) | Map Text Value -> Bool
forall k a. Map k a -> Bool
Map.null Map Text Value
xs  = U1 a -> Either String (U1 a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
    fromRonProduct RonSettings
_ ProductContext
c Either (Vector Value) (Map Text Value)
_ = String -> Either String (U1 a)
forall a. String -> ParseResult a
fail (String -> Either String (U1 a)) -> String -> Either String (U1 a)
forall a b. (a -> b) -> a -> b
$ ProductContext -> String
constructorName ProductContext
c String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": expected empty structure"

instance {-# OVERLAPPING #-} (Selector s, FromRon c)
    => GFromRonProduct (M1 S s (K1 R (Maybe c))) where
    fromRonProduct :: forall a.
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (M1 S s (K1 R (Maybe c)) a)
fromRonProduct RonSettings
conf ProductContext
cont Either (Vector Value) (Map Text Value)
xs =
        let field :: Text
field =
                String -> Text
pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RonSettings -> String -> String
fieldModifier RonSettings
conf (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
                    Any s (K1 R (Maybe c)) Any -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (t s (K1 R (Maybe c)) a
forall a. HasCallStack => a
forall {t :: Meta -> (* -> *) -> * -> *} {a}.
t s (K1 R (Maybe c)) a
undefined :: t s (K1 R (Maybe c)) a)
            ProductContext {String
constructorName :: ProductContext -> String
constructorName :: String
constructorName} = ProductContext
cont
        in case Either (Vector Value) (Map Text Value)
xs of
            Left Vector Value
xs' -> case Vector Value -> Maybe (Value, Vector Value)
forall a. Vector a -> Maybe (a, Vector a)
Vector.uncons Vector Value
xs' of
                Maybe (Value, Vector Value)
Nothing -> String -> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall a. String -> ParseResult a
fail (String -> ParseResult (M1 S s (K1 R (Maybe c)) a))
-> String -> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall a b. (a -> b) -> a -> b
$ String
"Not enough elements in tuple " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
constructorName
                Just (Value
x, Vector Value
xs'')
                    | Vector Value -> Bool
forall a. Vector a -> Bool
Vector.null Vector Value
xs'' -> K1 R (Maybe c) a -> M1 S s (K1 R (Maybe c)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R (Maybe c) a -> M1 S s (K1 R (Maybe c)) a)
-> Either String (K1 R (Maybe c) a)
-> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        let tryUnwrapped :: Either String (K1 i (Maybe c) p)
tryUnwrapped
                                | RonFlags -> Bool
implicitSome (RonFlags -> Bool)
-> (RonSettings -> RonFlags) -> RonSettings -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RonSettings -> RonFlags
decodeFlags (RonSettings -> Bool) -> RonSettings -> Bool
forall a b. (a -> b) -> a -> b
$ RonSettings
conf =
                                    Maybe c -> K1 i (Maybe c) p
forall k i c (p :: k). c -> K1 i c p
K1 (Maybe c -> K1 i (Maybe c) p)
-> (c -> Maybe c) -> c -> K1 i (Maybe c) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Maybe c
forall a. a -> Maybe a
Just (c -> K1 i (Maybe c) p)
-> Either String c -> Either String (K1 i (Maybe c) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either String c
forall a. FromRon a => Value -> ParseResult a
fromRon Value
x
                                | Bool
otherwise =
                                    String -> Either String (K1 i (Maybe c) p)
forall a. String -> ParseResult a
fail (String -> Either String (K1 i (Maybe c) p))
-> String -> Either String (K1 i (Maybe c) p)
forall a b. (a -> b) -> a -> b
$ String
constructorName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": not using decodeImplicitSome"
                        in RonSettings -> Value -> Either String (K1 R (Maybe c) a)
forall a. RonSettings -> Value -> ParseResult (K1 R (Maybe c) a)
forall (f :: * -> *) a.
GFromRonRec f =>
RonSettings -> Value -> ParseResult (f a)
fromRonRec RonSettings
conf Value
x Either String (K1 R (Maybe c) a)
-> Either String (K1 R (Maybe c) a)
-> Either String (K1 R (Maybe c) a)
forall a. ParseResult a -> ParseResult a -> ParseResult a
<<|>> Either String (K1 R (Maybe c) a)
forall {i} {p}. Either String (K1 i (Maybe c) p)
tryUnwrapped
                    | Bool
otherwise -> String -> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall a. String -> ParseResult a
fail (String -> ParseResult (M1 S s (K1 R (Maybe c)) a))
-> String -> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall a b. (a -> b) -> a -> b
$ String
"Trailing members in tuple " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
constructorName
            Right Map Text Value
xs'
                | RonFlags -> Bool
implicitSome (RonFlags -> Bool)
-> (RonSettings -> RonFlags) -> RonSettings -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RonSettings -> RonFlags
decodeFlags (RonSettings -> Bool) -> RonSettings -> Bool
forall a b. (a -> b) -> a -> b
$ RonSettings
conf ->
                    case Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
field Map Text Value
xs' of
                        Maybe Value
Nothing -> M1 S s (K1 R (Maybe c)) a
-> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (M1 S s (K1 R (Maybe c)) a
 -> ParseResult (M1 S s (K1 R (Maybe c)) a))
-> (Maybe c -> M1 S s (K1 R (Maybe c)) a)
-> Maybe c
-> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 R (Maybe c) a -> M1 S s (K1 R (Maybe c)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R (Maybe c) a -> M1 S s (K1 R (Maybe c)) a)
-> (Maybe c -> K1 R (Maybe c) a)
-> Maybe c
-> M1 S s (K1 R (Maybe c)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe c -> K1 R (Maybe c) a
forall k i c (p :: k). c -> K1 i c p
K1 (Maybe c -> ParseResult (M1 S s (K1 R (Maybe c)) a))
-> Maybe c -> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall a b. (a -> b) -> a -> b
$ Maybe c
forall a. Maybe a
Nothing
                        Just Value
x ->
                            let unwrapped :: Either String (M1 i c (K1 i (Maybe c)) p)
unwrapped = K1 i (Maybe c) p -> M1 i c (K1 i (Maybe c)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i (Maybe c) p -> M1 i c (K1 i (Maybe c)) p)
-> (c -> K1 i (Maybe c) p) -> c -> M1 i c (K1 i (Maybe c)) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe c -> K1 i (Maybe c) p
forall k i c (p :: k). c -> K1 i c p
K1 (Maybe c -> K1 i (Maybe c) p)
-> (c -> Maybe c) -> c -> K1 i (Maybe c) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Maybe c
forall a. a -> Maybe a
Just (c -> M1 i c (K1 i (Maybe c)) p)
-> Either String c -> Either String (M1 i c (K1 i (Maybe c)) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either String c
forall a. FromRon a => Value -> ParseResult a
fromRon Value
x
                                wrapped :: Either String (M1 i c (K1 R (Maybe c)) p)
wrapped = K1 R (Maybe c) p -> M1 i c (K1 R (Maybe c)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R (Maybe c) p -> M1 i c (K1 R (Maybe c)) p)
-> Either String (K1 R (Maybe c) p)
-> Either String (M1 i c (K1 R (Maybe c)) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RonSettings -> Value -> Either String (K1 R (Maybe c) p)
forall a. RonSettings -> Value -> ParseResult (K1 R (Maybe c) a)
forall (f :: * -> *) a.
GFromRonRec f =>
RonSettings -> Value -> ParseResult (f a)
fromRonRec RonSettings
conf Value
x
                            in ParseResult (M1 S s (K1 R (Maybe c)) a)
forall {i} {c :: Meta} {p}.
Either String (M1 i c (K1 R (Maybe c)) p)
wrapped ParseResult (M1 S s (K1 R (Maybe c)) a)
-> ParseResult (M1 S s (K1 R (Maybe c)) a)
-> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall a. ParseResult a -> ParseResult a -> ParseResult a
<<|>> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall {i} {c :: Meta} {i} {p}.
Either String (M1 i c (K1 i (Maybe c)) p)
unwrapped
                | Bool
otherwise -> case Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
field Map Text Value
xs' of
                    Maybe Value
Nothing -> String -> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall a. String -> ParseResult a
fail (String -> ParseResult (M1 S s (K1 R (Maybe c)) a))
-> String -> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall a b. (a -> b) -> a -> b
$ String
"Field " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
field String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" not present in record " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
constructorName
                    Just Value
x -> K1 R (Maybe c) a -> M1 S s (K1 R (Maybe c)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R (Maybe c) a -> M1 S s (K1 R (Maybe c)) a)
-> Either String (K1 R (Maybe c) a)
-> ParseResult (M1 S s (K1 R (Maybe c)) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RonSettings -> Value -> Either String (K1 R (Maybe c) a)
forall a. RonSettings -> Value -> ParseResult (K1 R (Maybe c) a)
forall (f :: * -> *) a.
GFromRonRec f =>
RonSettings -> Value -> ParseResult (f a)
fromRonRec RonSettings
conf Value
x

instance (Selector s, GFromRonRec f) => GFromRonProduct (M1 S s f) where
    fromRonProduct :: forall a.
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (M1 S s f a)
fromRonProduct RonSettings
conf ProductContext
cont Either (Vector Value) (Map Text Value)
xs =
        let field :: Text
field = String -> Text
pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RonSettings -> String -> String
fieldModifier RonSettings
conf (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Any s f Any -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (t s f a
forall a. HasCallStack => a
forall {t :: Meta -> (* -> *) -> * -> *} {a}. t s f a
undefined :: t s f a)
            ProductContext {String
constructorName :: ProductContext -> String
constructorName :: String
constructorName} = ProductContext
cont
        in case Either (Vector Value) (Map Text Value)
xs of
            Left Vector Value
xs' -> case Vector Value -> Maybe (Value, Vector Value)
forall a. Vector a -> Maybe (a, Vector a)
Vector.uncons Vector Value
xs' of
                Maybe (Value, Vector Value)
Nothing -> String -> ParseResult (M1 S s f a)
forall a. String -> ParseResult a
fail (String -> ParseResult (M1 S s f a))
-> String -> ParseResult (M1 S s f a)
forall a b. (a -> b) -> a -> b
$ String
"Not enough elements in tuple " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
constructorName
                Just (Value
x, Vector Value
xs'') | Vector Value -> Bool
forall a. Vector a -> Bool
Vector.null Vector Value
xs'' -> f a -> M1 S s f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 S s f a)
-> Either String (f a) -> ParseResult (M1 S s f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RonSettings -> Value -> Either String (f a)
forall a. RonSettings -> Value -> ParseResult (f a)
forall (f :: * -> *) a.
GFromRonRec f =>
RonSettings -> Value -> ParseResult (f a)
fromRonRec RonSettings
conf Value
x
                               | Bool
otherwise -> String -> ParseResult (M1 S s f a)
forall a. String -> ParseResult a
fail (String -> ParseResult (M1 S s f a))
-> String -> ParseResult (M1 S s f a)
forall a b. (a -> b) -> a -> b
$ String
"Trailing members in tuple " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
constructorName
            Right Map Text Value
xs' -> case Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
field Map Text Value
xs' of
                Maybe Value
Nothing -> String -> ParseResult (M1 S s f a)
forall a. String -> ParseResult a
fail (String -> ParseResult (M1 S s f a))
-> String -> ParseResult (M1 S s f a)
forall a b. (a -> b) -> a -> b
$ String
"Field " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
field String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" not present in record " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
constructorName
                Just Value
x -> f a -> M1 S s f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 S s f a)
-> Either String (f a) -> ParseResult (M1 S s f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RonSettings -> Value -> Either String (f a)
forall a. RonSettings -> Value -> ParseResult (f a)
forall (f :: * -> *) a.
GFromRonRec f =>
RonSettings -> Value -> ParseResult (f a)
fromRonRec RonSettings
conf Value
x

instance (ProductSize pl, GFromRonProduct pl, GFromRonProduct pr)
    => GFromRonProduct (pl :*: pr) where
    fromRonProduct :: forall a.
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult ((:*:) pl pr a)
fromRonProduct RonSettings
conf ProductContext
cont (Left Vector Value
xs) =
        let sizel :: Int
sizel = Proxy pl -> Int
forall (f :: * -> *). ProductSize f => Proxy f -> Int
productSize (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @pl)
            (Vector Value
xsl, Vector Value
xsr) = Int -> Vector Value -> (Vector Value, Vector Value)
forall a. Int -> Vector a -> (Vector a, Vector a)
Vector.splitAt Int
sizel Vector Value
xs
        in pl a -> pr a -> (:*:) pl pr a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
            (pl a -> pr a -> (:*:) pl pr a)
-> Either String (pl a) -> Either String (pr a -> (:*:) pl pr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> Either String (pl a)
forall a.
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (pl a)
forall (f :: * -> *) a.
GFromRonProduct f =>
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (f a)
fromRonProduct RonSettings
conf ProductContext
cont (Vector Value -> Either (Vector Value) (Map Text Value)
forall a b. a -> Either a b
Left Vector Value
xsl)
            Either String (pr a -> (:*:) pl pr a)
-> Either String (pr a) -> Either String ((:*:) pl pr a)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> Either String (pr a)
forall a.
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (pr a)
forall (f :: * -> *) a.
GFromRonProduct f =>
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (f a)
fromRonProduct RonSettings
conf ProductContext
cont (Vector Value -> Either (Vector Value) (Map Text Value)
forall a b. a -> Either a b
Left Vector Value
xsr)
    fromRonProduct RonSettings
conf ProductContext
cont Either (Vector Value) (Map Text Value)
xs = pl a -> pr a -> (:*:) pl pr a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
        (pl a -> pr a -> (:*:) pl pr a)
-> Either String (pl a) -> Either String (pr a -> (:*:) pl pr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> Either String (pl a)
forall a.
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (pl a)
forall (f :: * -> *) a.
GFromRonProduct f =>
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (f a)
fromRonProduct RonSettings
conf ProductContext
cont Either (Vector Value) (Map Text Value)
xs
        Either String (pr a -> (:*:) pl pr a)
-> Either String (pr a) -> Either String ((:*:) pl pr a)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> Either String (pr a)
forall a.
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (pr a)
forall (f :: * -> *) a.
GFromRonProduct f =>
RonSettings
-> ProductContext
-> Either (Vector Value) (Map Text Value)
-> ParseResult (f a)
fromRonProduct RonSettings
conf ProductContext
cont Either (Vector Value) (Map Text Value)
xs

instance FromRon c => GFromRonRec (K1 R c) where
    fromRonRec :: forall a. RonSettings -> Value -> ParseResult (K1 R c a)
fromRonRec RonSettings
_ Value
x = c -> K1 R c a
forall k i c (p :: k). c -> K1 i c p
K1 (c -> K1 R c a) -> Either String c -> Either String (K1 R c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either String c
forall a. FromRon a => Value -> ParseResult a
fromRon Value
x