{-|
Module      : Z.Data.YAML.FFI
Description : LibYAML bindings
Copyright   : (c) Dong Han, 2020
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

Simple YAML codec using <https://libyaml.docsforge.com/ libYAML> and JSON's 'JSON' utilities.
The design choice to make things as simple as possible since YAML is a complex format, there're some limitations using this approach:

* Does not support complex keys.
* Does not support multiple doucments in one file.

@
{-# LANGUAGE DeriveGeneric, DeriveAnyClass, DerivingStrategies, TypeApplication #-}

import           GHC.Generics
import qualified Z.Data.YAML as YAML
import qualified Z.Data.Text as T

data Person = Person
    { name  :: T.Text
    , age   :: Int
    , magic :: Bool
    }
  deriving (Show, Generic)
  deriving anyclass (YAML.JSON)

> YAML.decode @[Person] "- name: Erik Weisz\\n  age: 52\\n  magic: True\\n"
> Right [Person {name = "Erik Weisz", age = 52, magic = True}]
@

-}


module Z.Data.YAML
  ( -- * Decode and encode using YAML
    decode
  , encode
  , readYAMLFile
  , writeYAMLFile
  -- * Streaming parser and builder
  , parseSingleDoucment
  , parseAllDocuments
  , buildSingleDocument
  , buildValue
  -- * Errors
  , YAMLError(..)
  , YAMLParseError(..)
  , ConvertError(..)
  , DecodeError
  -- * Re-Exports
  , JSON(..)
  , Value(..)
  ) where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Reader
import           Data.Bits              ((.|.), unsafeShiftL)
import           Data.IORef
import qualified Data.HashMap.Strict    as HM
import qualified Data.HashSet           as HS
import qualified Data.Scientific        as Sci
import           GHC.Generics           (Generic)
import           System.IO.Unsafe
import           Z.Data.ASCII
import qualified Z.Data.Parser          as P
import qualified Z.Data.Vector          as V
import qualified Z.Data.Text            as T
import           Z.Data.JSON            (JSON(..), Value(..), ConvertError, convertValue)
import           Z.Data.YAML.FFI
import qualified Z.Data.Vector.FlatMap  as FM
import qualified Z.Data.Builder         as B
import           Z.Data.CBytes          (CBytes)
import           Z.Data.YAML.FFI
import           Z.IO

type DecodeError = Either YAMLError ConvertError

-- | Decode a 'JSON' instance from a YAML file.
readYAMLFile :: forall a. (HasCallStack, JSON a) => CBytes -> IO a
readYAMLFile :: CBytes -> IO a
readYAMLFile CBytes
p = Text -> Either (Either YAMLError ConvertError) a -> IO a
forall e a. (HasCallStack, Print e) => Text -> Either e a -> IO a
unwrap Text
"EPARSE" (Either (Either YAMLError ConvertError) a -> IO a)
-> IO (Either (Either YAMLError ConvertError) a) -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Resource (Source MarkedEvent)
-> (Source MarkedEvent
    -> IO (Either (Either YAMLError ConvertError) a))
-> IO (Either (Either YAMLError ConvertError) a)
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m, HasCallStack) =>
Resource a -> (a -> m b) -> m b
withResource (HasCallStack => CBytes -> Resource (Source MarkedEvent)
CBytes -> Resource (Source MarkedEvent)
initFileParser CBytes
p) (\ Source MarkedEvent
src -> do
    Either YAMLError Value
r <- IO Value -> IO (Either YAMLError Value)
forall e a. Exception e => IO a -> IO (Either e a)
try (HasCallStack => Source MarkedEvent -> IO Value
Source MarkedEvent -> IO Value
parseSingleDoucment Source MarkedEvent
src)
    case Either YAMLError Value
r of
        Left (YAMLError
e :: YAMLError) -> Either (Either YAMLError ConvertError) a
-> IO (Either (Either YAMLError ConvertError) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either YAMLError ConvertError
-> Either (Either YAMLError ConvertError) a
forall a b. a -> Either a b
Left (YAMLError -> Either YAMLError ConvertError
forall a b. a -> Either a b
Left YAMLError
e))
        Right Value
r' -> case (Value -> Either ConvertError a
forall a. JSON a => Value -> Either ConvertError a
convertValue Value
r' :: Either ConvertError a) of
            Left ConvertError
e' -> Either (Either YAMLError ConvertError) a
-> IO (Either (Either YAMLError ConvertError) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either YAMLError ConvertError
-> Either (Either YAMLError ConvertError) a
forall a b. a -> Either a b
Left (ConvertError -> Either YAMLError ConvertError
forall a b. b -> Either a b
Right ConvertError
e'))
            Right a
v -> Either (Either YAMLError ConvertError) a
-> IO (Either (Either YAMLError ConvertError) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either (Either YAMLError ConvertError) a
forall a b. b -> Either a b
Right a
v))

-- | Decode a 'JSON' instance from YAML bytes.
decode :: forall a .(HasCallStack, JSON a) => V.Bytes -> Either DecodeError a
decode :: Bytes -> Either (Either YAMLError ConvertError) a
decode Bytes
bs = IO (Either (Either YAMLError ConvertError) a)
-> Either (Either YAMLError ConvertError) a
forall a. IO a -> a
unsafePerformIO (IO (Either (Either YAMLError ConvertError) a)
 -> Either (Either YAMLError ConvertError) a)
-> ((Source MarkedEvent
     -> IO (Either (Either YAMLError ConvertError) a))
    -> IO (Either (Either YAMLError ConvertError) a))
-> (Source MarkedEvent
    -> IO (Either (Either YAMLError ConvertError) a))
-> Either (Either YAMLError ConvertError) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resource (Source MarkedEvent)
-> (Source MarkedEvent
    -> IO (Either (Either YAMLError ConvertError) a))
-> IO (Either (Either YAMLError ConvertError) a)
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m, HasCallStack) =>
Resource a -> (a -> m b) -> m b
withResource (Bytes -> Resource (Source MarkedEvent)
initParser Bytes
bs) ((Source MarkedEvent
  -> IO (Either (Either YAMLError ConvertError) a))
 -> Either (Either YAMLError ConvertError) a)
-> (Source MarkedEvent
    -> IO (Either (Either YAMLError ConvertError) a))
-> Either (Either YAMLError ConvertError) a
forall a b. (a -> b) -> a -> b
$ \ Source MarkedEvent
src -> do
    Either YAMLError Value
r <- IO Value -> IO (Either YAMLError Value)
forall e a. Exception e => IO a -> IO (Either e a)
try (HasCallStack => Source MarkedEvent -> IO Value
Source MarkedEvent -> IO Value
parseSingleDoucment Source MarkedEvent
src)
    case Either YAMLError Value
r of
        Left YAMLError
e -> Either (Either YAMLError ConvertError) a
-> IO (Either (Either YAMLError ConvertError) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either YAMLError ConvertError
-> Either (Either YAMLError ConvertError) a
forall a b. a -> Either a b
Left (YAMLError -> Either YAMLError ConvertError
forall a b. a -> Either a b
Left YAMLError
e))
        Right Value
r' -> case (Value -> Either ConvertError a
forall a. JSON a => Value -> Either ConvertError a
convertValue Value
r' :: Either ConvertError a) of
            Left ConvertError
e' -> Either (Either YAMLError ConvertError) a
-> IO (Either (Either YAMLError ConvertError) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either YAMLError ConvertError
-> Either (Either YAMLError ConvertError) a
forall a b. a -> Either a b
Left (ConvertError -> Either YAMLError ConvertError
forall a b. b -> Either a b
Right ConvertError
e'))
            Right a
v -> Either (Either YAMLError ConvertError) a
-> IO (Either (Either YAMLError ConvertError) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either (Either YAMLError ConvertError) a
forall a b. b -> Either a b
Right a
v)

-- | Encode a 'JSON' instance to YAML file.
writeYAMLFile :: (HasCallStack, JSON a) => YAMLFormatOpts -> CBytes -> a -> IO ()
writeYAMLFile :: YAMLFormatOpts -> CBytes -> a -> IO ()
writeYAMLFile YAMLFormatOpts
opts CBytes
p a
x = Resource (Sink Event) -> (Sink Event -> IO ()) -> IO ()
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m, HasCallStack) =>
Resource a -> (a -> m b) -> m b
withResource (HasCallStack => YAMLFormatOpts -> CBytes -> Resource (Sink Event)
YAMLFormatOpts -> CBytes -> Resource (Sink Event)
initFileEmitter YAMLFormatOpts
opts CBytes
p) ((Sink Event -> IO ()) -> IO ()) -> (Sink Event -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Sink Event
sink ->
    HasCallStack => Sink Event -> Value -> IO ()
Sink Event -> Value -> IO ()
buildSingleDocument Sink Event
sink (a -> Value
forall a. JSON a => a -> Value
toValue a
x)

-- | Encode a 'JSON' instance as UTF8 YAML text.
encode :: (HasCallStack, JSON a) => YAMLFormatOpts -> a -> T.Text
encode :: YAMLFormatOpts -> a -> Text
encode YAMLFormatOpts
opts a
x = IO Text -> Text
forall a. IO a -> a
unsafePerformIO (IO Text -> Text)
-> (((Ptr EmitterStruct, Sink Event) -> IO Text) -> IO Text)
-> ((Ptr EmitterStruct, Sink Event) -> IO Text)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resource (Ptr EmitterStruct, Sink Event)
-> ((Ptr EmitterStruct, Sink Event) -> IO Text) -> IO Text
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m, HasCallStack) =>
Resource a -> (a -> m b) -> m b
withResource (YAMLFormatOpts -> Resource (Ptr EmitterStruct, Sink Event)
initEmitter YAMLFormatOpts
opts) (((Ptr EmitterStruct, Sink Event) -> IO Text) -> Text)
-> ((Ptr EmitterStruct, Sink Event) -> IO Text) -> Text
forall a b. (a -> b) -> a -> b
$ \ (Ptr EmitterStruct
p, Sink Event
sink) -> do
    HasCallStack => Sink Event -> Value -> IO ()
Sink Event -> Value -> IO ()
buildSingleDocument Sink Event
sink (a -> Value
forall a. JSON a => a -> Value
toValue a
x)
    Ptr EmitterStruct -> IO Text
getEmitterResult Ptr EmitterStruct
p

--------------------------------------------------------------------------------

-- | Parse a single YAML document, throw 'OtherYAMLError' if multiple documents are met.
parseSingleDoucment :: HasCallStack => Source MarkedEvent -> IO Value
parseSingleDoucment :: Source MarkedEvent -> IO Value
parseSingleDoucment Source MarkedEvent
src = do
    [Value]
docs <- HasCallStack => Source MarkedEvent -> IO [Value]
Source MarkedEvent -> IO [Value]
parseAllDocuments Source MarkedEvent
src
    case [Value]
docs of
        [] -> Value -> IO Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
Null
        [Value
doc] -> Value -> IO Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
doc
        [Value]
_ -> YAMLError -> IO Value
forall e a. Exception e => e -> IO a
throwIO (Text -> YAMLError
OtherYAMLError Text
"multiple YAML documents")

-- | Parse all YAML documents.
parseAllDocuments :: HasCallStack => Source MarkedEvent -> IO [Value]
parseAllDocuments :: Source MarkedEvent -> IO [Value]
parseAllDocuments Source MarkedEvent
src = do
    Maybe MarkedEvent
me <- Source MarkedEvent -> IO (Maybe MarkedEvent)
forall inp out. BIO inp out -> IO (Maybe out)
pull Source MarkedEvent
src
    case Maybe MarkedEvent
me of
        Just (MarkedEvent Event
EventStreamStart Mark
_ Mark
_) -> do
            IORef (HashMap Text Value)
as <- HashMap Text Value -> IO (IORef (HashMap Text Value))
forall a. a -> IO (IORef a)
newIORef HashMap Text Value
forall k v. HashMap k v
HM.empty
            IO [Value] -> (YAMLParseError -> IO [Value]) -> IO [Value]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (ReaderT (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
-> (Source MarkedEvent, IORef (HashMap Text Value)) -> IO [Value]
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
parseDocs (Source MarkedEvent
src, IORef (HashMap Text Value)
as)) ((YAMLParseError -> IO [Value]) -> IO [Value])
-> (YAMLParseError -> IO [Value]) -> IO [Value]
forall a b. (a -> b) -> a -> b
$ \ (YAMLParseError
e :: YAMLParseError) ->
                YAMLParseError -> IO [Value]
forall a. YAMLParseError -> IO a
throwYAMLError YAMLParseError
e
        Just MarkedEvent
me' -> YAMLParseError -> IO [Value]
forall a. YAMLParseError -> IO a
throwYAMLError (MarkedEvent -> YAMLParseError
UnexpectedEvent MarkedEvent
me')
        -- empty file input, comment only string/file input
        Maybe MarkedEvent
_ -> [Value] -> IO [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
    parseDocs :: ReaderT (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
parseDocs = do
        MarkedEvent
me <- ParserIO MarkedEvent
pullEvent
        case MarkedEvent
me of
            MarkedEvent Event
EventStreamEnd Mark
_ Mark
_      -> [Value]
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            MarkedEvent Event
EventDocumentStart Mark
_ Mark
_  -> do
                Value
res <- MarkedEvent -> ParserIO Value
parseValue (MarkedEvent -> ParserIO Value)
-> ParserIO MarkedEvent -> ParserIO Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParserIO MarkedEvent
pullEvent
                MarkedEvent
me' <- ParserIO MarkedEvent
pullEvent
                case MarkedEvent
me' of
                    MarkedEvent Event
EventDocumentEnd Mark
_ Mark
_ ->
                        (Value
res Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:) ([Value] -> [Value])
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
parseDocs
                    MarkedEvent
me'' -> YAMLParseError
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
forall a. YAMLParseError -> ParserIO a
throwParserIO (MarkedEvent -> YAMLParseError
UnexpectedEvent MarkedEvent
me'')


type ParserIO = ReaderT (Source MarkedEvent, IORef (HM.HashMap T.Text Value)) IO

pullEvent :: ParserIO MarkedEvent
pullEvent :: ParserIO MarkedEvent
pullEvent = do
    (Source MarkedEvent
src, IORef (HashMap Text Value)
_) <- ReaderT
  (Source MarkedEvent, IORef (HashMap Text Value))
  IO
  (Source MarkedEvent, IORef (HashMap Text Value))
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    IO MarkedEvent -> ParserIO MarkedEvent
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MarkedEvent -> ParserIO MarkedEvent)
-> IO MarkedEvent -> ParserIO MarkedEvent
forall a b. (a -> b) -> a -> b
$ do
        Maybe MarkedEvent
me <- Source MarkedEvent -> IO (Maybe MarkedEvent)
forall inp out. BIO inp out -> IO (Maybe out)
pull Source MarkedEvent
src
        case Maybe MarkedEvent
me of Just MarkedEvent
e -> MarkedEvent -> IO MarkedEvent
forall (m :: * -> *) a. Monad m => a -> m a
return MarkedEvent
e
                   Maybe MarkedEvent
_ -> YAMLParseError -> IO MarkedEvent
forall e a. Exception e => e -> IO a
throwIO YAMLParseError
UnexpectedEventEnd

throwParserIO :: YAMLParseError -> ParserIO a
throwParserIO :: YAMLParseError -> ParserIO a
throwParserIO = IO a -> ParserIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ParserIO a)
-> (YAMLParseError -> IO a) -> YAMLParseError -> ParserIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. YAMLParseError -> IO a
forall e a. Exception e => e -> IO a
throwIO

defineAnchor :: T.Text -> Value -> ParserIO ()
defineAnchor :: Text -> Value -> ParserIO ()
defineAnchor Text
key Value
value = Bool -> ParserIO () -> ParserIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
key) (ParserIO () -> ParserIO ()) -> ParserIO () -> ParserIO ()
forall a b. (a -> b) -> a -> b
$ do
    (Source MarkedEvent
_, IORef (HashMap Text Value)
mref) <- ReaderT
  (Source MarkedEvent, IORef (HashMap Text Value))
  IO
  (Source MarkedEvent, IORef (HashMap Text Value))
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    IO () -> ParserIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ParserIO ()) -> IO () -> ParserIO ()
forall a b. (a -> b) -> a -> b
$ IORef (HashMap Text Value)
-> (HashMap Text Value -> HashMap Text Value) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (HashMap Text Value)
mref (Text -> Value -> HashMap Text Value -> HashMap Text Value
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key Value
value)

lookupAlias :: MarkedEvent -> T.Text -> ParserIO Value
lookupAlias :: MarkedEvent -> Text -> ParserIO Value
lookupAlias MarkedEvent
me Text
key = do
    (Source MarkedEvent
_, IORef (HashMap Text Value)
mref) <- ReaderT
  (Source MarkedEvent, IORef (HashMap Text Value))
  IO
  (Source MarkedEvent, IORef (HashMap Text Value))
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    IO Value -> ParserIO Value
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Value -> ParserIO Value) -> IO Value -> ParserIO Value
forall a b. (a -> b) -> a -> b
$ do
        HashMap Text Value
m <- IORef (HashMap Text Value) -> IO (HashMap Text Value)
forall a. IORef a -> IO a
readIORef IORef (HashMap Text Value)
mref
        case Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text Value
m of
            Just Value
v -> Value -> IO Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
            Maybe Value
_ -> YAMLParseError -> IO Value
forall e a. Exception e => e -> IO a
throwIO (MarkedEvent -> YAMLParseError
UnknownAlias MarkedEvent
me)

textToValue :: ScalarStyle -> Tag -> T.Text -> Value
textToValue :: ScalarStyle -> Tag -> Text -> Value
textToValue ScalarStyle
SingleQuoted Tag
_ Text
t = Text -> Value
String Text
t
textToValue ScalarStyle
DoubleQuoted Tag
_ Text
t = Text -> Value
String Text
t
textToValue ScalarStyle
_ Tag
StrTag Text
t       = Text -> Value
String Text
t
textToValue ScalarStyle
Folded Tag
_ Text
t       = Text -> Value
String Text
t
textToValue ScalarStyle
_ Tag
_ Text
t
    | Text
t Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"null", Text
"Null", Text
"NULL", Text
"~", Text
""] = Value
Null
    | Text
t Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"y", Text
"Y", Text
"yes", Text
"on", Text
"true", Text
"YES", Text
"ON", Text
"TRUE", Text
"Yes", Text
"On", Text
"True"]    = Bool -> Value
Bool Bool
True
    | Text
t Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"n", Text
"N", Text
"no", Text
"off", Text
"false", Text
"NO", Text
"OFF", Text
"FALSE", Text
"No", Text
"Off", Text
"False"] = Bool -> Value
Bool Bool
False
    | Right Scientific
x <- Text -> Either [Text] Scientific
textToScientific Text
t = Scientific -> Value
Number Scientific
x
    | Bool
otherwise = Text -> Value
String Text
t

textToScientific :: T.Text -> Either P.ParseError Sci.Scientific
textToScientific :: Text -> Either [Text] Scientific
textToScientific = Parser Scientific -> Bytes -> Either [Text] Scientific
forall a. Parser a -> Bytes -> Either [Text] a
P.parse' (Parser Scientific
num Parser Scientific -> Parser () -> Parser Scientific
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.endOfInput) (Bytes -> Either [Text] Scientific)
-> (Text -> Bytes) -> Text -> Either [Text] Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bytes
T.getUTF8Bytes
  where
    num :: Parser Scientific
num = (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Scientific) -> Parser Integer -> Parser Scientific
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bytes -> Parser ()
P.bytes Bytes
"0x" Parser () -> Parser Integer -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integral Integer, Bits Integer) => Parser Integer
forall a. (Integral a, Bits a) => Parser a
P.hex_ @Integer))
      Parser Scientific -> Parser Scientific -> Parser Scientific
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Scientific) -> Parser Integer -> Parser Scientific
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bytes -> Parser ()
P.bytes Bytes
"0o" Parser () -> Parser Integer -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Integer
octal))
      Parser Scientific -> Parser Scientific -> Parser Scientific
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Scientific
P.scientific

    octal :: Parser Integer
octal = (Integer -> Word8 -> Integer) -> Integer -> Bytes -> Integer
forall (v :: * -> *) a b. Vec v a => (b -> a -> b) -> b -> v a -> b
V.foldl' Integer -> Word8 -> Integer
forall a. (Bits a, Num a) => a -> Word8 -> a
step Integer
0 (Bytes -> Integer) -> Parser Bytes -> Parser Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser Bytes
P.takeWhile1 (\ Word8
w -> Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
DIGIT_0 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
DIGIT_0Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+Word8
8)
    step :: a -> Word8 -> a
step a
a Word8
c = (a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
3) a -> a -> a
forall a. Bits a => a -> a -> a
.|. Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
DIGIT_0)

parseValue :: MarkedEvent -> ParserIO Value
parseValue :: MarkedEvent -> ParserIO Value
parseValue me :: MarkedEvent
me@(MarkedEvent Event
e Mark
startMark Mark
endMark) =
    case Event
e of
        EventScalar Text
anchor Text
v Tag
tag ScalarStyle
style -> do
            let !v' :: Value
v' = ScalarStyle -> Tag -> Text -> Value
textToValue ScalarStyle
style Tag
tag Text
v
            Text -> Value -> ParserIO ()
defineAnchor Text
anchor Value
v'
            Value -> ParserIO Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v'
        EventSequenceStart Text
anchor Tag
_ ScalarStyle
_  -> do
            !Value
v <- ParserIO Value
parseSequence
            Text -> Value -> ParserIO ()
defineAnchor Text
anchor Value
v
            Value -> ParserIO Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
        EventMappingStart Text
anchor Tag
_ ScalarStyle
_   -> do
            !Value
v <- ParserIO Value
parseMapping
            Text -> Value -> ParserIO ()
defineAnchor Text
anchor Value
v
            Value -> ParserIO Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
        EventAlias Text
anchor              -> MarkedEvent -> Text -> ParserIO Value
lookupAlias MarkedEvent
me Text
anchor
        Event
_ -> YAMLParseError -> ParserIO Value
forall a. YAMLParseError -> ParserIO a
throwParserIO (MarkedEvent -> YAMLParseError
UnexpectedEvent MarkedEvent
me)

parseSequence :: ParserIO Value
parseSequence :: ParserIO Value
parseSequence = Vector Value -> Value
Array (Vector Value -> Value)
-> ([Value] -> Vector Value) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Vector Value
forall (v :: * -> *) a. Vec v a => [a] -> v a
V.packR ([Value] -> Value)
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
-> ParserIO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
go []
  where
    go :: [Value]
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
go [Value]
acc = do
        MarkedEvent
e <- ParserIO MarkedEvent
pullEvent
        case MarkedEvent
e of
            MarkedEvent Event
EventSequenceEnd Mark
_ Mark
_ -> [Value]
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
acc
            MarkedEvent
_ -> do
                Value
o <- MarkedEvent -> ParserIO Value
parseValue MarkedEvent
e
                [Value]
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [Value]
go (Value
oValue -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:[Value]
acc)

parseMapping :: ParserIO Value
parseMapping :: ParserIO Value
parseMapping = Vector (Text, Value) -> Value
Object (Vector (Text, Value) -> Value)
-> ([(Text, Value)] -> Vector (Text, Value))
-> [(Text, Value)]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> Vector (Text, Value)
forall (v :: * -> *) a. Vec v a => [a] -> v a
V.packR ([(Text, Value)] -> Value)
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [(Text, Value)]
-> ParserIO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Value)]
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [(Text, Value)]
go []
  where
    go :: [(Text, Value)]
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [(Text, Value)]
go [(Text, Value)]
acc = do
        MarkedEvent
me <- ParserIO MarkedEvent
pullEvent
        case MarkedEvent
me of
            MarkedEvent Event
EventMappingEnd Mark
_ Mark
_ -> [(Text, Value)]
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [(Text, Value)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Text, Value)]
acc
            MarkedEvent Event
e Mark
startMark Mark
endMark -> do
                Text
key <- case Event
e of
                    EventScalar Text
anchor Text
v Tag
tag ScalarStyle
style ->
                        case ScalarStyle -> Tag -> Text -> Value
textToValue ScalarStyle
style Tag
tag Text
v of
                            k :: Value
k@(String Text
k') -> do
                                Text -> Value -> ParserIO ()
defineAnchor Text
anchor Value
k
                                Text
-> ReaderT (Source MarkedEvent, IORef (HashMap Text Value)) IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
k'
                            Value
_ -> YAMLParseError
-> ReaderT (Source MarkedEvent, IORef (HashMap Text Value)) IO Text
forall a. YAMLParseError -> ParserIO a
throwParserIO (MarkedEvent -> YAMLParseError
NonStringKey MarkedEvent
me)

                    EventAlias Text
anchor -> do
                        Value
m <- MarkedEvent -> Text -> ParserIO Value
lookupAlias MarkedEvent
me Text
anchor
                        case Value
m of
                            String Text
k -> Text
-> ReaderT (Source MarkedEvent, IORef (HashMap Text Value)) IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
k
                            Value
_ -> YAMLParseError
-> ReaderT (Source MarkedEvent, IORef (HashMap Text Value)) IO Text
forall a. YAMLParseError -> ParserIO a
throwParserIO (MarkedEvent -> YAMLParseError
NonStringKeyAlias MarkedEvent
me)
                    Event
e -> YAMLParseError
-> ReaderT (Source MarkedEvent, IORef (HashMap Text Value)) IO Text
forall a. YAMLParseError -> ParserIO a
throwParserIO (MarkedEvent -> YAMLParseError
UnexpectedEvent MarkedEvent
me)

                Value
value <- MarkedEvent -> ParserIO Value
parseValue (MarkedEvent -> ParserIO Value)
-> ParserIO MarkedEvent -> ParserIO Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParserIO MarkedEvent
pullEvent

                -- overidding
                if Text
key Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"<<"
                then case Value
value of
                    -- overide a mapping literal
                    Object Vector (Text, Value)
kvs  -> [(Text, Value)]
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [(Text, Value)]
go (Vector (Text, Value) -> [(Text, Value)]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpackR Vector (Text, Value)
kvs [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++ [(Text, Value)]
acc)
                    -- overide a mapping list
                    Array Vector Value
vs -> [(Text, Value)]
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [(Text, Value)]
go ((Value -> [(Text, Value)] -> [(Text, Value)])
-> [(Text, Value)] -> Vector Value -> [(Text, Value)]
forall (v :: * -> *) a b. Vec v a => (a -> b -> b) -> b -> v a -> b
V.foldr' Value -> [(Text, Value)] -> [(Text, Value)]
mergeMapping [(Text, Value)]
acc Vector Value
vs)
                    Value
v          ->  YAMLParseError
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [(Text, Value)]
forall a. YAMLParseError -> ParserIO a
throwParserIO (MarkedEvent -> YAMLParseError
UnexpectedEvent MarkedEvent
me)

                else [(Text, Value)]
-> ReaderT
     (Source MarkedEvent, IORef (HashMap Text Value)) IO [(Text, Value)]
go ((Text
key, Value
value)(Text, Value) -> [(Text, Value)] -> [(Text, Value)]
forall a. a -> [a] -> [a]
:[(Text, Value)]
acc)

    -- ignore non-object
    mergeMapping :: Value -> [(Text, Value)] -> [(Text, Value)]
mergeMapping  (Object Vector (Text, Value)
o) [(Text, Value)]
acc = [(Text, Value)]
acc [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++ Vector (Text, Value) -> [(Text, Value)]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpackR Vector (Text, Value)
o
    mergeMapping  Value
v          [(Text, Value)]
acc = [(Text, Value)]
acc

--------------------------------------------------------------------------------

-- | Write a value as a YAML document stream.
--
buildSingleDocument :: HasCallStack => Sink Event -> Value -> IO ()
buildSingleDocument :: Sink Event -> Value -> IO ()
buildSingleDocument Sink Event
sink Value
v = do
    Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink Event
EventStreamStart
    Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink Event
EventDocumentStart
    HasCallStack => Sink Event -> Value -> IO ()
Sink Event -> Value -> IO ()
buildValue Sink Event
sink Value
v
    Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink Event
EventDocumentEnd
    IO (Maybe Void) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Void) -> IO ()) -> IO (Maybe Void) -> IO ()
forall a b. (a -> b) -> a -> b
$ Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink Event
EventStreamEnd

-- | Write a value as a stream of 'Event's(without document start\/end, stream start\/end).
--
buildValue :: HasCallStack => Sink Event -> Value -> IO ()
buildValue :: Sink Event -> Value -> IO ()
buildValue Sink Event
sink (Array Vector Value
vs) = do
    Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink (Text -> Tag -> ScalarStyle -> Event
EventSequenceStart Text
"" Tag
NoTag ScalarStyle
AnySequence)
    (Value -> IO ()) -> [Value] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HasCallStack => Sink Event -> Value -> IO ()
Sink Event -> Value -> IO ()
buildValue Sink Event
sink) (Vector Value -> [Value]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector Value
vs)
    IO (Maybe Void) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Void) -> IO ()) -> IO (Maybe Void) -> IO ()
forall a b. (a -> b) -> a -> b
$ Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink Event
EventSequenceEnd

buildValue Sink Event
sink (Object Vector (Text, Value)
o) = do
    Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink (Text -> Tag -> ScalarStyle -> Event
EventMappingStart Text
"" Tag
NoTag ScalarStyle
AnyMapping)
    ((Text, Value) -> IO ()) -> [(Text, Value)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text, Value) -> IO ()
encodeKV (Vector (Text, Value) -> [(Text, Value)]
forall (v :: * -> *) a. Vec v a => v a -> [a]
V.unpack Vector (Text, Value)
o)
    IO (Maybe Void) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Void) -> IO ()) -> IO (Maybe Void) -> IO ()
forall a b. (a -> b) -> a -> b
$ Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink Event
EventMappingEnd
  where
    encodeKV :: (Text, Value) -> IO ()
encodeKV (Text
k, Value
v) = HasCallStack => Sink Event -> Value -> IO ()
Sink Event -> Value -> IO ()
buildValue Sink Event
sink (Text -> Value
String Text
k) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HasCallStack => Sink Event -> Value -> IO ()
Sink Event -> Value -> IO ()
buildValue Sink Event
sink Value
v

buildValue Sink Event
sink (String Text
s) = IO (Maybe Void) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Void) -> IO ()) -> IO (Maybe Void) -> IO ()
forall a b. (a -> b) -> a -> b
$ Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink (Text -> Text -> Tag -> ScalarStyle -> Event
EventScalar Text
"" Text
s Tag
NoTag (Text -> ScalarStyle
stringStyle Text
s))
  where
    stringStyle :: Text -> ScalarStyle
stringStyle Text
s
        | (Int
_, Just Char
_) <- (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') (Char -> Bool) -> Text -> (Int, Maybe Char)
`T.find` Text
s   = ScalarStyle
Literal
        | Text -> Bool
isSpecialString Text
s                     = ScalarStyle
SingleQuoted
        | Bool
otherwise                             = ScalarStyle
PlainNoTag

    isSpecialString :: Text -> Bool
isSpecialString Text
s = Text
s Text -> HashSet Text -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet Text
specialStrings Bool -> Bool -> Bool
|| Text -> Bool
isNumeric Text
s
    specialStrings :: HashSet Text
specialStrings = [Text] -> HashSet Text
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([Text] -> HashSet Text) -> [Text] -> HashSet Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words
        Text
"y Y yes Yes YES n N no No NO true True TRUE false False FALSE on On ON off Off OFF null Null NULL ~ *"
    isNumeric :: Text -> Bool
isNumeric = ([Text] -> Bool)
-> (Scientific -> Bool) -> Either [Text] Scientific -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> [Text] -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> Scientific -> Bool
forall a b. a -> b -> a
const Bool
True) (Either [Text] Scientific -> Bool)
-> (Text -> Either [Text] Scientific) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either [Text] Scientific
textToScientific

buildValue Sink Event
sink Value
Null         = IO (Maybe Void) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Void) -> IO ()) -> IO (Maybe Void) -> IO ()
forall a b. (a -> b) -> a -> b
$ Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink (Text -> Text -> Tag -> ScalarStyle -> Event
EventScalar Text
"" Text
"null" Tag
NullTag ScalarStyle
PlainNoTag)
buildValue Sink Event
sink (Bool Bool
True)  = IO (Maybe Void) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Void) -> IO ()) -> IO (Maybe Void) -> IO ()
forall a b. (a -> b) -> a -> b
$ Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink (Text -> Text -> Tag -> ScalarStyle -> Event
EventScalar Text
"" Text
"true" Tag
BoolTag ScalarStyle
PlainNoTag)
buildValue Sink Event
sink (Bool Bool
False) = IO (Maybe Void) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Void) -> IO ()) -> IO (Maybe Void) -> IO ()
forall a b. (a -> b) -> a -> b
$ Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink (Text -> Text -> Tag -> ScalarStyle -> Event
EventScalar Text
"" Text
"false" Tag
BoolTag ScalarStyle
PlainNoTag)
buildValue Sink Event
sink (Number Scientific
s)   = do
    let builder :: Builder ()
builder
            -- Special case the 0 exponent to remove the trailing .0
            | Scientific -> Int
Sci.base10Exponent Scientific
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Integer -> Builder ()
B.integer (Integer -> Builder ()) -> Integer -> Builder ()
forall a b. (a -> b) -> a -> b
$ Scientific -> Integer
Sci.coefficient Scientific
s
            | Bool
otherwise = Scientific -> Builder ()
B.scientific Scientific
s
        t :: Text
t = Builder () -> Text
forall a. Builder a -> Text
B.unsafeBuildText Builder ()
builder
    IO (Maybe Void) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Void) -> IO ()) -> IO (Maybe Void) -> IO ()
forall a b. (a -> b) -> a -> b
$ Sink Event -> Event -> IO (Maybe Void)
forall inp out. BIO inp out -> inp -> IO (Maybe out)
push Sink Event
sink (Text -> Text -> Tag -> ScalarStyle -> Event
EventScalar Text
"" Text
t Tag
IntTag ScalarStyle
PlainNoTag)