{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE Safe              #-}

-- |
-- Copyright: © Herbert Valerio Riedel 2015-2018
-- SPDX-License-Identifier: GPL-2.0-or-later
--
module Data.YAML.Dumper
    ( encodeNode
    , encodeNode'
    ) where

import           Data.YAML.Event.Internal  as YE
import           Data.YAML.Event.Writer    (writeEvents)
import           Data.YAML.Internal        as YI
import           Data.YAML.Schema.Internal as YS

import qualified Data.ByteString.Lazy      as BS.L
import qualified Data.Map                  as Map
import qualified Data.Text                 as T

-- internal
type EvList = [Either String Event]
type Node2EvList = [Node ()] -> EvList

-- | Dump YAML Nodes as a lazy 'UTF8' encoded 'BS.L.ByteString'
--
-- Each YAML 'Node' is emitted as a individual YAML Document where each Document is terminated by a 'DocumentEnd' indicator.
--
-- This is a convenience wrapper over `encodeNode'`
--
-- @since 0.2.0
encodeNode :: [Doc (Node ())] -> BS.L.ByteString
encodeNode :: [Doc (Node ())] -> ByteString
encodeNode = SchemaEncoder -> Encoding -> [Doc (Node ())] -> ByteString
encodeNode' SchemaEncoder
coreSchemaEncoder Encoding
UTF8

-- | Customizable variant of 'encodeNode'
--
-- __NOTE__: A leading <https://en.wikipedia.org/wiki/Byte_order_mark BOM> will be emitted for all encodings /other than/ 'UTF8'.
--
-- @since 0.2.0
encodeNode' :: SchemaEncoder -> Encoding -> [Doc (Node ())] -> BS.L.ByteString
encodeNode' :: SchemaEncoder -> Encoding -> [Doc (Node ())] -> ByteString
encodeNode' SchemaEncoder{..} encoding :: Encoding
encoding nodes :: [Doc (Node ())]
nodes = Encoding -> [Event] -> ByteString
writeEvents Encoding
encoding ([Event] -> ByteString) -> [Event] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Either String Event -> Event) -> [Either String Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map Either String Event -> Event
getEvent (Node2EvList
dumpEvents ((Doc (Node ()) -> Node ()) -> [Doc (Node ())] -> [Node ()]
forall a b. (a -> b) -> [a] -> [b]
map Doc (Node ()) -> Node ()
forall n. Doc n -> n
docRoot [Doc (Node ())]
nodes))
  where

    getEvent :: Either String Event -> Event
    getEvent :: Either String Event -> Event
getEvent = \x :: Either String Event
x -> case Either String Event
x of
      Right ev :: Event
ev -> Event
ev
      Left str :: String
str -> String -> Event
forall a. HasCallStack => String -> a
error String
str

    dumpEvents :: Node2EvList
    dumpEvents :: Node2EvList
dumpEvents nodes' :: [Node ()]
nodes' = Event -> Either String Event
forall a b. b -> Either a b
Right Event
StreamStartEither String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Node2EvList
go0 [Node ()]
nodes'
      where
        go0 :: [Node ()] -> EvList
        go0 :: Node2EvList
go0 [] = [Event -> Either String Event
forall a b. b -> Either a b
Right Event
StreamEnd]
        go0 n :: [Node ()]
n  = Event -> Either String Event
forall a b. b -> Either a b
Right (Directives -> Event
DocumentStart Directives
NoDirEndMarker)Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Int -> [Node ()] -> Node2EvList -> [Either String Event]
goNode (0 :: Int) [Node ()]
n (\ev :: [Node ()]
ev -> Node2EvList
go0 [Node ()]
ev)


        goNode :: Int -> [Node ()] -> Node2EvList -> EvList
        goNode :: Int -> [Node ()] -> Node2EvList -> [Either String Event]
goNode _ [] _ = [String -> Either String Event
forall a b. a -> Either a b
Left "Dumper: unexpected pattern in goNode"]
        goNode lvl :: Int
lvl (node :: Node ()
node: rest :: [Node ()]
rest) cont :: Node2EvList
cont = case Node ()
node of
          YI.Scalar _ scalar :: Scalar
scalar -> Scalar -> Maybe Text -> Either String Event
goScalar Scalar
scalar Maybe Text
forall a. Maybe a
NothingEither String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Int -> [Node ()] -> Node2EvList -> [Either String Event]
isDocEnd Int
lvl [Node ()]
rest Node2EvList
cont
          Mapping   _ tag :: Tag
tag m :: Mapping ()
m  -> Event -> Either String Event
forall a b. b -> Either a b
Right (Maybe Text -> Tag -> NodeStyle -> Event
MappingStart Maybe Text
forall a. Maybe a
Nothing ((Tag -> Either String Tag) -> Tag -> Tag
getTag Tag -> Either String Tag
schemaEncoderMapping Tag
tag) NodeStyle
Block) Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Int
-> Mapping () -> [Node ()] -> Node2EvList -> [Either String Event]
goMap (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Mapping ()
m [Node ()]
rest Node2EvList
cont
          Sequence  _ tag :: Tag
tag s :: [Node ()]
s  -> Event -> Either String Event
forall a b. b -> Either a b
Right (Maybe Text -> Tag -> NodeStyle -> Event
SequenceStart Maybe Text
forall a. Maybe a
Nothing ((Tag -> Either String Tag) -> Tag -> Tag
getTag Tag -> Either String Tag
schemaEncoderSequence Tag
tag) NodeStyle
Block) Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Int
-> [Node ()] -> [Node ()] -> Node2EvList -> [Either String Event]
goSeq (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) [Node ()]
s [Node ()]
rest Node2EvList
cont
          Anchor    _ nid :: NodeId
nid n :: Node ()
n  -> Int
-> NodeId
-> Node ()
-> [Node ()]
-> Node2EvList
-> [Either String Event]
goAnchor Int
lvl NodeId
nid Node ()
n [Node ()]
rest Node2EvList
cont

        goScalar :: YS.Scalar -> Maybe Anchor -> Either String Event
        goScalar :: Scalar -> Maybe Text -> Either String Event
goScalar s :: Scalar
s anc :: Maybe Text
anc = case Scalar -> Either String (Tag, ScalarStyle, Text)
schemaEncoderScalar Scalar
s of
            Right (t :: Tag
t, sty :: ScalarStyle
sty, text :: Text
text) -> Event -> Either String Event
forall a b. b -> Either a b
Right (Maybe Text -> Tag -> ScalarStyle -> Text -> Event
YE.Scalar Maybe Text
anc Tag
t ScalarStyle
sty Text
text)
            Left err :: String
err             -> String -> Either String Event
forall a b. a -> Either a b
Left String
err

        goMap :: Int -> Mapping () -> [Node ()] -> Node2EvList -> EvList
        goMap :: Int
-> Mapping () -> [Node ()] -> Node2EvList -> [Either String Event]
goMap lvl :: Int
lvl m :: Mapping ()
m rest :: [Node ()]
rest cont :: Node2EvList
cont = case (Mapping () -> [Node ()]
forall a. Map a a -> [a]
mapToList Mapping ()
m) of
          []   -> Event -> Either String Event
forall a b. b -> Either a b
Right Event
MappingEnd Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Int -> [Node ()] -> Node2EvList -> [Either String Event]
isDocEnd (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) [Node ()]
rest Node2EvList
cont
          list :: [Node ()]
list -> Int -> [Node ()] -> Node2EvList -> [Either String Event]
goNode Int
lvl [Node ()]
list Node2EvList
g
          where
            g :: Node2EvList
g []    = Event -> Either String Event
forall a b. b -> Either a b
Right Event
MappingEnd Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Int -> [Node ()] -> Node2EvList -> [Either String Event]
isDocEnd (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) [Node ()]
rest Node2EvList
cont
            g rest' :: [Node ()]
rest' = Int -> [Node ()] -> Node2EvList -> [Either String Event]
goNode Int
lvl [Node ()]
rest' Node2EvList
g
            mapToList :: Map a a -> [a]
mapToList = (a -> a -> [a] -> [a]) -> [a] -> Map a a -> [a]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\k :: a
k v :: a
v a :: [a]
a -> a
k a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
a) []

        goSeq :: Int -> [Node ()] -> [Node ()] -> Node2EvList -> EvList
        goSeq :: Int
-> [Node ()] -> [Node ()] -> Node2EvList -> [Either String Event]
goSeq lvl :: Int
lvl []  rest :: [Node ()]
rest cont :: Node2EvList
cont = Event -> Either String Event
forall a b. b -> Either a b
Right Event
SequenceEnd Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Int -> [Node ()] -> Node2EvList -> [Either String Event]
isDocEnd (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) [Node ()]
rest Node2EvList
cont
        goSeq lvl :: Int
lvl nod :: [Node ()]
nod rest :: [Node ()]
rest cont :: Node2EvList
cont = Int -> [Node ()] -> Node2EvList -> [Either String Event]
goNode Int
lvl [Node ()]
nod Node2EvList
g
          where
            g :: Node2EvList
g []    = Event -> Either String Event
forall a b. b -> Either a b
Right Event
SequenceEnd Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Int -> [Node ()] -> Node2EvList -> [Either String Event]
isDocEnd (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) [Node ()]
rest Node2EvList
cont
            g rest' :: [Node ()]
rest' = Int -> [Node ()] -> Node2EvList -> [Either String Event]
goNode Int
lvl [Node ()]
rest' Node2EvList
g

        goAnchor :: Int -> NodeId -> Node () -> [Node ()] -> Node2EvList -> EvList
        goAnchor :: Int
-> NodeId
-> Node ()
-> [Node ()]
-> Node2EvList
-> [Either String Event]
goAnchor lvl :: Int
lvl nid :: NodeId
nid nod :: Node ()
nod rest :: [Node ()]
rest cont :: Node2EvList
cont = case Node ()
nod of
          YI.Scalar _ scalar :: Scalar
scalar -> Scalar -> Maybe Text -> Either String Event
goScalar Scalar
scalar (NodeId -> Maybe Text
ancName NodeId
nid)Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Int -> [Node ()] -> Node2EvList -> [Either String Event]
isDocEnd Int
lvl [Node ()]
rest Node2EvList
cont
          Mapping   _ tag :: Tag
tag m :: Mapping ()
m  -> Event -> Either String Event
forall a b. b -> Either a b
Right (Maybe Text -> Tag -> NodeStyle -> Event
MappingStart (NodeId -> Maybe Text
ancName NodeId
nid) ((Tag -> Either String Tag) -> Tag -> Tag
getTag Tag -> Either String Tag
schemaEncoderMapping Tag
tag) NodeStyle
Block) Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Int
-> Mapping () -> [Node ()] -> Node2EvList -> [Either String Event]
goMap (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Mapping ()
m [Node ()]
rest Node2EvList
cont
          Sequence  _ tag :: Tag
tag s :: [Node ()]
s  -> Event -> Either String Event
forall a b. b -> Either a b
Right (Maybe Text -> Tag -> NodeStyle -> Event
SequenceStart (NodeId -> Maybe Text
ancName NodeId
nid) ((Tag -> Either String Tag) -> Tag -> Tag
getTag Tag -> Either String Tag
schemaEncoderSequence Tag
tag) NodeStyle
Block) Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: Int
-> [Node ()] -> [Node ()] -> Node2EvList -> [Either String Event]
goSeq (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) [Node ()]
s [Node ()]
rest Node2EvList
cont
          Anchor    _ _ _    -> String -> Either String Event
forall a b. a -> Either a b
Left "Anchor has a anchor node" Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: (Node2EvList
cont [Node ()]
rest)

        isDocEnd :: Int -> [Node ()] -> Node2EvList -> EvList
        isDocEnd :: Int -> [Node ()] -> Node2EvList -> [Either String Event]
isDocEnd lvl :: Int
lvl rest :: [Node ()]
rest cont :: Node2EvList
cont = if Int
lvl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then Event -> Either String Event
forall a b. b -> Either a b
Right (Bool -> Event
DocumentEnd ([Node ()]
rest [Node ()] -> [Node ()] -> Bool
forall a. Eq a => a -> a -> Bool
/= []))Either String Event
-> [Either String Event] -> [Either String Event]
forall a. a -> [a] -> [a]
: (Node2EvList
cont [Node ()]
rest) else (Node2EvList
cont [Node ()]
rest)

        ancName :: NodeId -> Maybe Anchor
        ancName :: NodeId -> Maybe Text
ancName nid :: NodeId
nid
          | NodeId
nid NodeId -> NodeId -> Bool
forall a. Eq a => a -> a -> Bool
== (0NodeId -> NodeId -> NodeId
forall a. Num a => a -> a -> a
-1) = Maybe Text
forall a. Maybe a
Nothing
          | Bool
otherwise    = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$! String -> Text
T.pack ("a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ NodeId -> String
forall a. Show a => a -> String
show NodeId
nid)

        getTag :: (Tag -> Either String Tag) -> Tag -> Tag
        getTag :: (Tag -> Either String Tag) -> Tag -> Tag
getTag f :: Tag -> Either String Tag
f tag :: Tag
tag = case Tag -> Either String Tag
f Tag
tag of
          Right t :: Tag
t  -> Tag
t
          Left err :: String
err -> String -> Tag
forall a. HasCallStack => String -> a
error String
err