{-# 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 bs = case decodeValue bs of
Left err -> Left err
Right vs -> case vs of
[] -> Left (zeroPos, "No documents found in YAML stream")
(_:_:_) -> Left (dummyPos, "Multiple documents encountered in YAML stream")
[v1] -> do
case J.fromJSON v1 of
J.Success v2 -> Right $! v2
J.Error err -> Left (dummyPos, "fromJSON: " ++ err)
where
zeroPos = Pos { posByteOffset = 0, posCharOffset = 0, posLine = 1, posColumn = 0 }
dummyPos = Pos { posByteOffset = -1, posCharOffset = -1, posLine = 1, posColumn = 0 }
decode1Strict :: FromJSON v => BS.ByteString -> Either (Pos,String) v
decode1Strict = decode1 . BS.L.fromChunks . (:[])
decode1' :: FromJSON v => SchemaResolver -> (J.Value -> Either String Text) -> BS.L.ByteString -> Either (Pos,String) v
decode1' schema keyconv bs = case decodeValue' schema keyconv bs of
Left err -> Left err
Right vs -> case vs of
[] -> Left (zeroPos, "No documents found in YAML stream")
(_:_:_) -> Left (dummyPos, "Multiple documents encountered in YAML stream")
[v1] -> do
case J.fromJSON v1 of
J.Success v2 -> Right $! v2
J.Error err -> Left (dummyPos, "fromJSON: " ++ err)
where
zeroPos = Pos { posByteOffset = 0, posCharOffset = 0, posLine = 1, posColumn = 0 }
dummyPos = Pos { posByteOffset = -1, posCharOffset = -1, posLine = 1, posColumn = 0 }
decodeValue :: BS.L.ByteString -> Either (Pos, String) [J.Value]
decodeValue = decodeValue' coreSchemaResolver identityKeyConv
where
identityKeyConv :: J.Value -> Either String Text
identityKeyConv (J.String k) = Right k
identityKeyConv _ = Left "non-String key encountered in mapping"
decodeValue' :: SchemaResolver
-> (J.Value -> Either String Text)
-> BS.L.ByteString
-> Either (Pos, String) [J.Value]
decodeValue' SchemaResolver{..} keyconv bs0
= runIdentity (decodeLoader failsafeLoader bs0)
where
failsafeLoader = Loader { yScalar = \t s v pos -> pure $! case schemaResolverScalar t s v of
Left e -> Left (pos, e)
Right vs -> mkScl vs pos
, ySequence = \t vs pos -> pure $! case schemaResolverSequence t of
Left e -> Left (pos, e)
Right _ -> mkArr vs
, yMapping = \t kvs pos -> pure $! case schemaResolverMapping t of
Left e -> Left (pos, e)
Right _ -> mkObj pos kvs
, yAlias = \_ c n pos -> pure $! if c then Left (pos, "cycle detected") else Right n
, yAnchor = \_ n _ -> Ap.pure $! Right $! n
}
mkObj :: Pos -> [(J.Value, J.Value)] -> Either (Pos, String) J.Value
mkObj pos xs = object <$> mapM (mkPair pos) xs
mkPair :: Pos -> (J.Value,J.Value) -> Either (Pos, String) J.Pair
mkPair pos (k, v) = case keyconv k of
Right k' -> Right (k', v)
Left s -> Left (pos, s)
mkArr :: [J.Value] -> Either (Pos, String) J.Value
mkArr xs = Right $! J.Array $! V.fromList xs
mkScl :: Y.Scalar -> Pos -> Either (Pos, String) J.Value
mkScl s pos = case scalarToValue s of
Nothing -> Left (pos, "unresolved YAML scalar encountered")
Just v -> Right $! v
scalarToValue :: Scalar -> Maybe J.Value
scalarToValue Y.SNull = Just J.Null
scalarToValue (Y.SBool b) = Just $! J.Bool b
scalarToValue (Y.SFloat x) = Just $! J.Number (realToFrac x)
scalarToValue (Y.SInt i) = Just $! J.Number (fromInteger i)
scalarToValue (SStr t) = Just $! J.String t
scalarToValue (SUnknown _ _) = Nothing
{-# INLINE bsToStrict #-}
bsToStrict :: BS.L.ByteString -> BS.ByteString
#if MIN_VERSION_bytestring(0,10,0)
bsToStrict = BS.L.toStrict
#else
bsToStrict = BS.concat . BS.L.toChunks
#endif
instance ToYAML J.Value where
toYAML J.Null = Scalar () SNull
toYAML (J.Bool b) = toYAML b
toYAML (J.String txt) = toYAML txt
toYAML (J.Number sc) = case floatingOrInteger sc :: Either Double Integer of
Right d -> toYAML d
Left int -> toYAML int
toYAML (J.Array a) = toYAML (V.toList a)
toYAML (J.Object o) = toYAML (Map.fromList (HM.toList o))
encode1 :: ToJSON v => v -> BS.L.ByteString
encode1 a = encodeValue [J.toJSON a]
encode1Strict :: ToJSON v => v -> BS.ByteString
encode1Strict = bsToStrict . encode1
encodeValue :: [J.Value] -> BS.L.ByteString
encodeValue = encodeValue' coreSchemaEncoder YT.UTF8
encodeValue' :: SchemaEncoder -> YT.Encoding -> [J.Value] -> BS.L.ByteString
encodeValue' schemaEncoder encoding values = Y.encodeNode' schemaEncoder encoding (map (Doc. toYAML) values)