{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.YAML.Aeson
(
decode1
, decode1'
, decode1Strict
, decodeValue
, decodeValue'
, scalarToValue
, encode1
, encode1Strict
, encodeValue
, encodeValue'
) where
import Control.Applicative as Ap
import Control.Monad.Identity (runIdentity)
import Data.Aeson as J
import qualified Data.Aeson.Types as J
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BS.L
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as Map
import Data.Scientific
import Data.Text (Text)
import qualified Data.Vector as V
import Data.YAML as Y hiding (decode1, decode1Strict, encode1, encode1Strict)
import Data.YAML.Schema
import qualified Data.YAML.Token as YT
decode1 :: FromJSON v => BS.L.ByteString -> Either (Pos,String) v
decode1 :: ByteString -> Either (Pos, String) v
decode1 bs :: ByteString
bs = case ByteString -> Either (Pos, String) [Value]
decodeValue ByteString
bs of
Left err :: (Pos, String)
err -> (Pos, String) -> Either (Pos, String) v
forall a b. a -> Either a b
Left (Pos, String)
err
Right vs :: [Value]
vs -> case [Value]
vs of
[] -> (Pos, String) -> Either (Pos, String) v
forall a b. a -> Either a b
Left (Pos
zeroPos, "No documents found in YAML stream")
(_:_:_) -> (Pos, String) -> Either (Pos, String) v
forall a b. a -> Either a b
Left (Pos
dummyPos, "Multiple documents encountered in YAML stream")
[v1 :: Value
v1] -> do
case Value -> Result v
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
v1 of
J.Success v2 :: v
v2 -> v -> Either (Pos, String) v
forall a b. b -> Either a b
Right (v -> Either (Pos, String) v) -> v -> Either (Pos, String) v
forall a b. (a -> b) -> a -> b
$! v
v2
J.Error err :: String
err -> (Pos, String) -> Either (Pos, String) v
forall a b. a -> Either a b
Left (Pos
dummyPos, "fromJSON: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
where
zeroPos :: Pos
zeroPos = $WPos :: Int -> Int -> Int -> Int -> Pos
Pos { posByteOffset :: Int
posByteOffset = 0, posCharOffset :: Int
posCharOffset = 0, posLine :: Int
posLine = 1, posColumn :: Int
posColumn = 0 }
dummyPos :: Pos
dummyPos = $WPos :: Int -> Int -> Int -> Int -> Pos
Pos { posByteOffset :: Int
posByteOffset = -1, posCharOffset :: Int
posCharOffset = -1, posLine :: Int
posLine = 1, posColumn :: Int
posColumn = 0 }
decode1Strict :: FromJSON v => BS.ByteString -> Either (Pos,String) v
decode1Strict :: ByteString -> Either (Pos, String) v
decode1Strict = ByteString -> Either (Pos, String) v
forall v. FromJSON v => ByteString -> Either (Pos, String) v
decode1 (ByteString -> Either (Pos, String) v)
-> (ByteString -> ByteString)
-> ByteString
-> Either (Pos, String) v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BS.L.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[])
decode1' :: FromJSON v => SchemaResolver -> (J.Value -> Either String Text) -> BS.L.ByteString -> Either (Pos,String) v
decode1' :: SchemaResolver
-> (Value -> Either String Text)
-> ByteString
-> Either (Pos, String) v
decode1' schema :: SchemaResolver
schema keyconv :: Value -> Either String Text
keyconv bs :: ByteString
bs = case SchemaResolver
-> (Value -> Either String Text)
-> ByteString
-> Either (Pos, String) [Value]
decodeValue' SchemaResolver
schema Value -> Either String Text
keyconv ByteString
bs of
Left err :: (Pos, String)
err -> (Pos, String) -> Either (Pos, String) v
forall a b. a -> Either a b
Left (Pos, String)
err
Right vs :: [Value]
vs -> case [Value]
vs of
[] -> (Pos, String) -> Either (Pos, String) v
forall a b. a -> Either a b
Left (Pos
zeroPos, "No documents found in YAML stream")
(_:_:_) -> (Pos, String) -> Either (Pos, String) v
forall a b. a -> Either a b
Left (Pos
dummyPos, "Multiple documents encountered in YAML stream")
[v1 :: Value
v1] -> do
case Value -> Result v
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
v1 of
J.Success v2 :: v
v2 -> v -> Either (Pos, String) v
forall a b. b -> Either a b
Right (v -> Either (Pos, String) v) -> v -> Either (Pos, String) v
forall a b. (a -> b) -> a -> b
$! v
v2
J.Error err :: String
err -> (Pos, String) -> Either (Pos, String) v
forall a b. a -> Either a b
Left (Pos
dummyPos, "fromJSON: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
where
zeroPos :: Pos
zeroPos = $WPos :: Int -> Int -> Int -> Int -> Pos
Pos { posByteOffset :: Int
posByteOffset = 0, posCharOffset :: Int
posCharOffset = 0, posLine :: Int
posLine = 1, posColumn :: Int
posColumn = 0 }
dummyPos :: Pos
dummyPos = $WPos :: Int -> Int -> Int -> Int -> Pos
Pos { posByteOffset :: Int
posByteOffset = -1, posCharOffset :: Int
posCharOffset = -1, posLine :: Int
posLine = 1, posColumn :: Int
posColumn = 0 }
decodeValue :: BS.L.ByteString -> Either (Pos, String) [J.Value]
decodeValue :: ByteString -> Either (Pos, String) [Value]
decodeValue = SchemaResolver
-> (Value -> Either String Text)
-> ByteString
-> Either (Pos, String) [Value]
decodeValue' SchemaResolver
coreSchemaResolver Value -> Either String Text
identityKeyConv
where
identityKeyConv :: J.Value -> Either String Text
identityKeyConv :: Value -> Either String Text
identityKeyConv (J.String k :: Text
k) = Text -> Either String Text
forall a b. b -> Either a b
Right Text
k
identityKeyConv _ = String -> Either String Text
forall a b. a -> Either a b
Left "non-String key encountered in mapping"
decodeValue' :: SchemaResolver
-> (J.Value -> Either String Text)
-> BS.L.ByteString
-> Either (Pos, String) [J.Value]
decodeValue' :: SchemaResolver
-> (Value -> Either String Text)
-> ByteString
-> Either (Pos, String) [Value]
decodeValue' SchemaResolver{..} keyconv :: Value -> Either String Text
keyconv bs0 :: ByteString
bs0
= Identity (Either (Pos, String) [Value])
-> Either (Pos, String) [Value]
forall a. Identity a -> a
runIdentity (Loader Identity Value
-> ByteString -> Identity (Either (Pos, String) [Value])
forall n (m :: * -> *).
MonadFix m =>
Loader m n -> ByteString -> m (Either (Pos, String) [n])
decodeLoader Loader Identity Value
failsafeLoader ByteString
bs0)
where
failsafeLoader :: Loader Identity Value
failsafeLoader = Loader :: forall (m :: * -> *) n.
(Tag -> ScalarStyle -> Text -> LoaderT m n)
-> (Tag -> [n] -> LoaderT m n)
-> (Tag -> [(n, n)] -> LoaderT m n)
-> (NodeId -> Bool -> n -> LoaderT m n)
-> (NodeId -> n -> LoaderT m n)
-> Loader m n
Loader { yScalar :: Tag -> ScalarStyle -> Text -> LoaderT Identity Value
yScalar = \t :: Tag
t s :: ScalarStyle
s v :: Text
v pos :: Pos
pos -> Either (Pos, String) Value -> Identity (Either (Pos, String) Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Pos, String) Value
-> Identity (Either (Pos, String) Value))
-> Either (Pos, String) Value
-> Identity (Either (Pos, String) Value)
forall a b. (a -> b) -> a -> b
$! case Tag -> ScalarStyle -> Text -> Either String Scalar
schemaResolverScalar Tag
t ScalarStyle
s Text
v of
Left e :: String
e -> (Pos, String) -> Either (Pos, String) Value
forall a b. a -> Either a b
Left (Pos
pos, String
e)
Right vs :: Scalar
vs -> Scalar -> Pos -> Either (Pos, String) Value
mkScl Scalar
vs Pos
pos
, ySequence :: Tag -> [Value] -> LoaderT Identity Value
ySequence = \t :: Tag
t vs :: [Value]
vs pos :: Pos
pos -> Either (Pos, String) Value -> Identity (Either (Pos, String) Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Pos, String) Value
-> Identity (Either (Pos, String) Value))
-> Either (Pos, String) Value
-> Identity (Either (Pos, String) Value)
forall a b. (a -> b) -> a -> b
$! case Tag -> Either String Tag
schemaResolverSequence Tag
t of
Left e :: String
e -> (Pos, String) -> Either (Pos, String) Value
forall a b. a -> Either a b
Left (Pos
pos, String
e)
Right _ -> [Value] -> Either (Pos, String) Value
mkArr [Value]
vs
, yMapping :: Tag -> [(Value, Value)] -> LoaderT Identity Value
yMapping = \t :: Tag
t kvs :: [(Value, Value)]
kvs pos :: Pos
pos -> Either (Pos, String) Value -> Identity (Either (Pos, String) Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Pos, String) Value
-> Identity (Either (Pos, String) Value))
-> Either (Pos, String) Value
-> Identity (Either (Pos, String) Value)
forall a b. (a -> b) -> a -> b
$! case Tag -> Either String Tag
schemaResolverMapping Tag
t of
Left e :: String
e -> (Pos, String) -> Either (Pos, String) Value
forall a b. a -> Either a b
Left (Pos
pos, String
e)
Right _ -> Pos -> [(Value, Value)] -> Either (Pos, String) Value
mkObj Pos
pos [(Value, Value)]
kvs
, yAlias :: NodeId -> Bool -> Value -> LoaderT Identity Value
yAlias = \_ c :: Bool
c n :: Value
n pos :: Pos
pos -> Either (Pos, String) Value -> Identity (Either (Pos, String) Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Pos, String) Value
-> Identity (Either (Pos, String) Value))
-> Either (Pos, String) Value
-> Identity (Either (Pos, String) Value)
forall a b. (a -> b) -> a -> b
$! if Bool
c then (Pos, String) -> Either (Pos, String) Value
forall a b. a -> Either a b
Left (Pos
pos, "cycle detected") else Value -> Either (Pos, String) Value
forall a b. b -> Either a b
Right Value
n
, yAnchor :: NodeId -> Value -> LoaderT Identity Value
yAnchor = \_ n :: Value
n _ -> Either (Pos, String) Value -> Identity (Either (Pos, String) Value)
forall (f :: * -> *) a. Applicative f => a -> f a
Ap.pure (Either (Pos, String) Value
-> Identity (Either (Pos, String) Value))
-> Either (Pos, String) Value
-> Identity (Either (Pos, String) Value)
forall a b. (a -> b) -> a -> b
$! Value -> Either (Pos, String) Value
forall a b. b -> Either a b
Right (Value -> Either (Pos, String) Value)
-> Value -> Either (Pos, String) Value
forall a b. (a -> b) -> a -> b
$! Value
n
}
mkObj :: Pos -> [(J.Value, J.Value)] -> Either (Pos, String) J.Value
mkObj :: Pos -> [(Value, Value)] -> Either (Pos, String) Value
mkObj pos :: Pos
pos xs :: [(Value, Value)]
xs = [Pair] -> Value
object ([Pair] -> Value)
-> Either (Pos, String) [Pair] -> Either (Pos, String) Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Value, Value) -> Either (Pos, String) Pair)
-> [(Value, Value)] -> Either (Pos, String) [Pair]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Pos -> (Value, Value) -> Either (Pos, String) Pair
mkPair Pos
pos) [(Value, Value)]
xs
mkPair :: Pos -> (J.Value,J.Value) -> Either (Pos, String) J.Pair
mkPair :: Pos -> (Value, Value) -> Either (Pos, String) Pair
mkPair pos :: Pos
pos (k :: Value
k, v :: Value
v) = case Value -> Either String Text
keyconv Value
k of
Right k' :: Text
k' -> Pair -> Either (Pos, String) Pair
forall a b. b -> Either a b
Right (Text
k', Value
v)
Left s :: String
s -> (Pos, String) -> Either (Pos, String) Pair
forall a b. a -> Either a b
Left (Pos
pos, String
s)
mkArr :: [J.Value] -> Either (Pos, String) J.Value
mkArr :: [Value] -> Either (Pos, String) Value
mkArr xs :: [Value]
xs = Value -> Either (Pos, String) Value
forall a b. b -> Either a b
Right (Value -> Either (Pos, String) Value)
-> Value -> Either (Pos, String) Value
forall a b. (a -> b) -> a -> b
$! Array -> Value
J.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$! [Value] -> Array
forall a. [a] -> Vector a
V.fromList [Value]
xs
mkScl :: Y.Scalar -> Pos -> Either (Pos, String) J.Value
mkScl :: Scalar -> Pos -> Either (Pos, String) Value
mkScl s :: Scalar
s pos :: Pos
pos = case Scalar -> Maybe Value
scalarToValue Scalar
s of
Nothing -> (Pos, String) -> Either (Pos, String) Value
forall a b. a -> Either a b
Left (Pos
pos, "unresolved YAML scalar encountered")
Just v :: Value
v -> Value -> Either (Pos, String) Value
forall a b. b -> Either a b
Right (Value -> Either (Pos, String) Value)
-> Value -> Either (Pos, String) Value
forall a b. (a -> b) -> a -> b
$! Value
v
scalarToValue :: Scalar -> Maybe J.Value
scalarToValue :: Scalar -> Maybe Value
scalarToValue Y.SNull = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
J.Null
scalarToValue (Y.SBool b :: Bool
b) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$! Bool -> Value
J.Bool Bool
b
scalarToValue (Y.SFloat x :: Double
x) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$! Scientific -> Value
J.Number (Double -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
x)
scalarToValue (Y.SInt i :: Integer
i) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$! Scientific -> Value
J.Number (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger Integer
i)
scalarToValue (SStr t :: Text
t) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$! Text -> Value
J.String Text
t
scalarToValue (SUnknown _ _) = Maybe Value
forall a. Maybe a
Nothing
{-# INLINE bsToStrict #-}
bsToStrict :: BS.L.ByteString -> BS.ByteString
#if MIN_VERSION_bytestring(0,10,0)
bsToStrict :: ByteString -> ByteString
bsToStrict = ByteString -> ByteString
BS.L.toStrict
#else
bsToStrict = BS.concat . BS.L.toChunks
#endif
instance ToYAML J.Value where
toYAML :: Value -> Node ()
toYAML J.Null = () -> Scalar -> Node ()
forall loc. loc -> Scalar -> Node loc
Scalar () Scalar
SNull
toYAML (J.Bool b :: Bool
b) = Bool -> Node ()
forall a. ToYAML a => a -> Node ()
toYAML Bool
b
toYAML (J.String txt :: Text
txt) = Text -> Node ()
forall a. ToYAML a => a -> Node ()
toYAML Text
txt
toYAML (J.Number sc :: Scientific
sc) = case Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
sc :: Either Double Integer of
Right d :: Integer
d -> Integer -> Node ()
forall a. ToYAML a => a -> Node ()
toYAML Integer
d
Left int :: Double
int -> Double -> Node ()
forall a. ToYAML a => a -> Node ()
toYAML Double
int
toYAML (J.Array a :: Array
a) = [Value] -> Node ()
forall a. ToYAML a => a -> Node ()
toYAML (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
a)
toYAML (J.Object o :: Object
o) = Map Text Value -> Node ()
forall a. ToYAML a => a -> Node ()
toYAML ([Pair] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Object -> [Pair]
forall k v. HashMap k v -> [(k, v)]
HM.toList Object
o))
encode1 :: ToJSON v => v -> BS.L.ByteString
encode1 :: v -> ByteString
encode1 a :: v
a = [Value] -> ByteString
encodeValue [v -> Value
forall a. ToJSON a => a -> Value
J.toJSON v
a]
encode1Strict :: ToJSON v => v -> BS.ByteString
encode1Strict :: v -> ByteString
encode1Strict = ByteString -> ByteString
bsToStrict (ByteString -> ByteString) -> (v -> ByteString) -> v -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> ByteString
forall v. ToJSON v => v -> ByteString
encode1
encodeValue :: [J.Value] -> BS.L.ByteString
encodeValue :: [Value] -> ByteString
encodeValue = SchemaEncoder -> Encoding -> [Value] -> ByteString
encodeValue' SchemaEncoder
coreSchemaEncoder Encoding
YT.UTF8
encodeValue' :: SchemaEncoder -> YT.Encoding -> [J.Value] -> BS.L.ByteString
encodeValue' :: SchemaEncoder -> Encoding -> [Value] -> ByteString
encodeValue' schemaEncoder :: SchemaEncoder
schemaEncoder encoding :: Encoding
encoding values :: [Value]
values = SchemaEncoder -> Encoding -> [Doc (Node ())] -> ByteString
Y.encodeNode' SchemaEncoder
schemaEncoder Encoding
encoding ((Value -> Doc (Node ())) -> [Value] -> [Doc (Node ())]
forall a b. (a -> b) -> [a] -> [b]
map (Node () -> Doc (Node ())
forall n. n -> Doc n
Doc(Node () -> Doc (Node ()))
-> (Value -> Node ()) -> Value -> Doc (Node ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Node ()
forall a. ToYAML a => a -> Node ()
toYAML) [Value]
values)