{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe              #-}


-- |
-- Copyright: © Herbert Valerio Riedel 2015-2018
-- SPDX-License-Identifier: GPL-2.0-or-later
--
-- Event-stream oriented YAML writer API
--
module Data.YAML.Event.Writer
    ( writeEvents
    , writeEventsText
    ) where

import           Data.YAML.Event.Internal

import qualified Data.ByteString.Lazy     as BS.L
import qualified Data.Char                as C
import qualified Data.Map                 as Map
import qualified Data.Text                as T
import           Text.Printf              (printf)

import qualified Data.Text.Lazy           as T.L
import qualified Data.Text.Lazy.Builder   as T.B
import qualified Data.Text.Lazy.Encoding  as T.L

import           Util


{- WARNING: the code that follows will make you cry; a safety pig is provided below for your benefit.

                         _
 _._ _..._ .-',     _.._(`))
'-. `     '  /-._.-'    ',/
   )         \            '.
  / _    _    |             \
 |  a    a    /              |
 \   .-.                     ;
  '-('' ).-'       ,'       ;
     '-;           |      .'
        \           \    /
        | 7  .__  _.-\   \
        | |  |  ``/  /`  /
       /,_|  |   /,_/   /
          /,_/      '`-'

-}

-- | Serialise 'Event's using specified UTF encoding to a lazy 'BS.L.ByteString'
--
-- __NOTE__: This function is only well-defined for valid 'Event' streams
--
-- @since 0.2.0.0
writeEvents :: Encoding -> [Event] -> BS.L.ByteString
writeEvents :: Encoding -> [Event] -> ByteString
writeEvents UTF8    = Text -> ByteString
T.L.encodeUtf8    (Text -> ByteString) -> ([Event] -> Text) -> [Event] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Text
writeEventsText
writeEvents UTF16LE = Text -> ByteString
T.L.encodeUtf16LE (Text -> ByteString) -> ([Event] -> Text) -> [Event] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
T.L.cons '\xfeff' (Text -> Text) -> ([Event] -> Text) -> [Event] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Text
writeEventsText
writeEvents UTF16BE = Text -> ByteString
T.L.encodeUtf16BE (Text -> ByteString) -> ([Event] -> Text) -> [Event] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
T.L.cons '\xfeff' (Text -> Text) -> ([Event] -> Text) -> [Event] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Text
writeEventsText
writeEvents UTF32LE = Text -> ByteString
T.L.encodeUtf32LE (Text -> ByteString) -> ([Event] -> Text) -> [Event] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
T.L.cons '\xfeff' (Text -> Text) -> ([Event] -> Text) -> [Event] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Text
writeEventsText
writeEvents UTF32BE = Text -> ByteString
T.L.encodeUtf32BE (Text -> ByteString) -> ([Event] -> Text) -> [Event] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
T.L.cons '\xfeff' (Text -> Text) -> ([Event] -> Text) -> [Event] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Text
writeEventsText

-- | Serialise 'Event's to lazy 'T.L.Text'
--
-- __NOTE__: This function is only well-defined for valid 'Event' streams
--
-- @since 0.2.0.0
writeEventsText :: [Event] -> T.L.Text
writeEventsText :: [Event] -> Text
writeEventsText [] = Text
forall a. Monoid a => a
mempty
writeEventsText (StreamStart:xs :: [Event]
xs) = Builder -> Text
T.B.toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ [Event] -> Any -> Builder
forall t. [Event] -> t -> Builder
goStream [Event]
xs ([Char] -> Any
forall a. HasCallStack => [Char] -> a
error "writeEvents: internal error")
  where
    -- goStream :: [Event] -> [Event] -> T.B.Builder
    goStream :: [Event] -> t -> Builder
goStream [StreamEnd] _ = Builder
forall a. Monoid a => a
mempty
    goStream (StreamEnd : _ : _ ) _cont :: t
_cont = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error "writeEvents: events after StreamEnd"
    goStream (Comment com :: Text
com: rest :: [Event]
rest) cont :: t
cont = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment (0 :: Int) Bool
True Context
BlockIn Text
com ([Event] -> t -> Builder
goStream [Event]
rest t
cont)
    goStream (DocumentStart marker :: Directives
marker : rest :: [Event]
rest) cont :: t
cont
      = case Directives
marker of
          NoDirEndMarker         -> Bool -> [Event] -> ([Event] -> Builder) -> Builder
putNode Bool
False [Event]
rest (\zs :: [Event]
zs -> [Event] -> t -> Builder
goDoc [Event]
zs t
cont)
          DirEndMarkerNoVersion  -> "---" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> [Event] -> ([Event] -> Builder) -> Builder
putNode Bool
True [Event]
rest (\zs :: [Event]
zs -> [Event] -> t -> Builder
goDoc [Event]
zs t
cont)
          DirEndMarkerVersion mi :: Word
mi -> "%YAML 1." Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ([Char] -> Builder
T.B.fromString (Word -> [Char]
forall a. Show a => a -> [Char]
show Word
mi)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "\n---" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> [Event] -> ([Event] -> Builder) -> Builder
putNode Bool
True [Event]
rest (\zs :: [Event]
zs -> [Event] -> t -> Builder
goDoc [Event]
zs t
cont)
    goStream (x :: Event
x:_) _cont :: t
_cont = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error ("writeEvents: unexpected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Event -> [Char]
forall a. Show a => a -> [Char]
show Event
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ " (expected DocumentStart or StreamEnd)")
    goStream [] _cont :: t
_cont = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error ("writeEvents: unexpected end of stream (expected DocumentStart or StreamEnd)")

    goDoc :: [Event] -> t -> Builder
goDoc (DocumentEnd marker :: Bool
marker : rest :: [Event]
rest) cont :: t
cont
      = (if Bool
marker then "...\n" else Builder
forall a. Monoid a => a
mempty) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> t -> Builder
goStream [Event]
rest t
cont
    goDoc (Comment com :: Text
com: rest :: [Event]
rest) cont :: t
cont = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment (0 :: Int) Bool
True Context
BlockIn Text
com ([Event] -> t -> Builder
goDoc [Event]
rest t
cont)
    goDoc ys :: [Event]
ys _ = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error ([Event] -> [Char]
forall a. Show a => a -> [Char]
show [Event]
ys)

    -- unexpected s l = error ("writeEvents: unexpected " ++ show l ++ " " ++ show s)

writeEventsText (x :: Event
x:_) = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ("writeEvents: unexpected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Event -> [Char]
forall a. Show a => a -> [Char]
show Event
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ " (expected StreamStart)")

-- | Production context -- copied from Data.YAML.Token
data Context = BlockOut     -- ^ Outside block sequence.
             | BlockIn      -- ^ Inside block sequence.
             | BlockKey     -- ^ Implicit block key.
             | FlowOut      -- ^ Outside flow collection.
             | FlowIn       -- ^ Inside flow collection.
             | FlowKey      -- ^ Implicit flow key.
             deriving (Context -> Context -> Bool
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c== :: Context -> Context -> Bool
Eq,Int -> Context -> [Char] -> [Char]
[Context] -> [Char] -> [Char]
Context -> [Char]
(Int -> Context -> [Char] -> [Char])
-> (Context -> [Char])
-> ([Context] -> [Char] -> [Char])
-> Show Context
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Context] -> [Char] -> [Char]
$cshowList :: [Context] -> [Char] -> [Char]
show :: Context -> [Char]
$cshow :: Context -> [Char]
showsPrec :: Int -> Context -> [Char] -> [Char]
$cshowsPrec :: Int -> Context -> [Char] -> [Char]
Show)

goComment :: Int -> Bool -> Context -> T.Text -> T.B.Builder -> T.B.Builder
goComment :: Int -> Bool -> Context -> Text -> Builder -> Builder
goComment !Int
n !Bool
sol c :: Context
c comment :: Text
comment cont :: Builder
cont = Builder
doSol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "#" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
T.B.fromText Text
comment) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
doEol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
doIndent Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont
  where
    doEol :: Builder
doEol
      | Bool -> Bool
not Bool
sol Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0  = Builder
forall a. Monoid a => a
mempty           -- "--- " case
      | Bool
sol Bool -> Bool -> Bool
&& Context
FlowIn Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
c = Builder
forall a. Monoid a => a
mempty
      | Bool
otherwise = Builder
eol

    doSol :: Builder
doSol
      | Bool -> Bool
not Bool
sol Bool -> Bool -> Bool
&& (Context
BlockOut Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
c Bool -> Bool -> Bool
|| Context
FlowOut Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
c) = Builder
ws
      | Bool
sol = Int -> Builder
mkInd Int
n'
      | Bool
otherwise = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd Int
n'

    n' :: Int
n'
      | Context
BlockOut <- Context
c = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
      | Context
FlowOut  <- Context
c = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
      | Bool
otherwise     = Int
n

    doIndent :: Builder
doIndent
      | Context
BlockOut <- Context
c = Int -> Builder
mkInd Int
n'
      | Context
FlowOut  <- Context
c = Int -> Builder
mkInd Int
n'
      | Bool
otherwise = Builder
forall a. Monoid a => a
mempty

putNode :: Bool -> [Event] -> ([Event] -> T.B.Builder) -> T.B.Builder
putNode :: Bool -> [Event] -> ([Event] -> Builder) -> Builder
putNode = \docMarker :: Bool
docMarker -> Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go (-1 :: Int) (Bool -> Bool
not Bool
docMarker) Context
BlockIn
  where

    {-  s-l+block-node(n,c)

        [196]   s-l+block-node(n,c)        ::=     s-l+block-in-block(n,c) | s-l+flow-in-block(n)

        [197]   s-l+flow-in-block(n)       ::=     s-separate(n+1,flow-out) ns-flow-node(n+1,flow-out) s-l-comments

        [198]   s-l+block-in-block(n,c)    ::=     s-l+block-scalar(n,c) | s-l+block-collection(n,c)

        [199]   s-l+block-scalar(n,c)      ::=     s-separate(n+1,c) ( c-ns-properties(n+1,c) s-separate(n+1,c) )?  ( c-l+literal(n) | c-l+folded(n) )

        [200]   s-l+block-collection(n,c)  ::=     ( s-separate(n+1,c) c-ns-properties(n+1,c) )? s-l-comments
                                                   ( l+block-sequence(seq-spaces(n,c)) | l+block-mapping(n) )

        [201]   seq-spaces(n,c)            ::=     c = block-out ⇒ n-1
                                                   c = block-in  ⇒ n

    -}

    go :: Int -> Bool -> Context -> [Event] -> ([Event] -> T.B.Builder) -> T.B.Builder
    go :: Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go _  _ _  [] _cont :: [Event] -> Builder
_cont = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error ("putNode: expected node-start event instead of end-of-stream")
    go !Int
n !Bool
sol c :: Context
c (t :: Event
t : rest :: [Event]
rest) cont :: [Event] -> Builder
cont = case Event
t of
        Scalar        anc :: Maybe Text
anc tag :: Tag
tag sty :: ScalarStyle
sty t' :: Text
t' -> Int
-> Bool
-> Context
-> Maybe Text
-> Tag
-> ScalarStyle
-> Text
-> Builder
-> Builder
goStr (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Bool
sol Context
c Maybe Text
anc Tag
tag ScalarStyle
sty Text
t' ([Event] -> Builder
cont [Event]
rest)
        SequenceStart anc :: Maybe Text
anc tag :: Tag
tag sty :: NodeStyle
sty    -> Int
-> Bool
-> Context
-> Maybe Text
-> Tag
-> NodeStyle
-> [Event]
-> ([Event] -> Builder)
-> Builder
goSeq (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Bool
sol (NodeStyle -> Context
chn NodeStyle
sty) Maybe Text
anc Tag
tag NodeStyle
sty [Event]
rest [Event] -> Builder
cont
        MappingStart  anc :: Maybe Text
anc tag :: Tag
tag sty :: NodeStyle
sty    -> Int
-> Bool
-> Context
-> Maybe Text
-> Tag
-> NodeStyle
-> [Event]
-> ([Event] -> Builder)
-> Builder
goMap (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Bool
sol (NodeStyle -> Context
chn NodeStyle
sty) Maybe Text
anc Tag
tag NodeStyle
sty [Event]
rest [Event] -> Builder
cont
        Alias a :: Text
a                      -> Builder
pfx Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Context -> Text -> Builder -> Builder
goAlias Context
c Text
a ([Event] -> Builder
cont [Event]
rest)
        Comment com :: Text
com                  -> Int -> Bool -> Context -> Text -> Builder -> Builder
goComment (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Bool
sol Context
c Text
com (Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n Bool
sol Context
c [Event]
rest [Event] -> Builder
cont)
        _ -> [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error ("putNode: expected node-start event instead of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Event -> [Char]
forall a. Show a => a -> [Char]
show Event
t)

      where
        pfx :: Builder
pfx | Bool
sol           = Builder
forall a. Monoid a => a
mempty
            | Context
BlockKey <- Context
c = Builder
forall a. Monoid a => a
mempty
            | Context
FlowKey  <- Context
c = Builder
forall a. Monoid a => a
mempty
            | Bool
otherwise     = Char -> Builder
T.B.singleton ' '

        chn :: NodeStyle -> Context
chn sty :: NodeStyle
sty
          | NodeStyle
Flow <-NodeStyle
sty, (Context
BlockIn Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
c Bool -> Bool -> Bool
|| Context
BlockOut Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
c) = Context
FlowOut
          | Bool
otherwise = Context
c


    goMap :: Int
-> Bool
-> Context
-> Maybe Text
-> Tag
-> NodeStyle
-> [Event]
-> ([Event] -> Builder)
-> Builder
goMap _ sol :: Bool
sol _ anc :: Maybe Text
anc tag :: Tag
tag _ (MappingEnd : rest :: [Event]
rest) cont :: [Event] -> Builder
cont = Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ "{}\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont [Event]
rest
      where
        pfx :: Builder -> Builder
pfx cont' :: Builder
cont' = Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' (Builder -> Either Builder Builder
forall a b. b -> Either a b
Right Builder
ws) Maybe Text
anc Tag
tag Builder
cont'

    goMap n :: Int
n sol :: Bool
sol c :: Context
c anc :: Maybe Text
anc tag :: Tag
tag Block xs :: [Event]
xs cont :: [Event] -> Builder
cont = case Context
c of
        BlockIn | Bool -> Bool
not (Bool -> Bool
not Bool
sol Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0) -- avoid "--- " case
           ->  Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' (Builder -> Either Builder Builder
forall a b. b -> Either a b
Right (Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd Int
n)) Maybe Text
anc Tag
tag
               ([Event] -> ([Event] -> Builder) -> Builder
putKey [Event]
xs [Event] -> Builder
putValue')
        _  ->  Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' (Builder -> Either Builder Builder
forall a b. a -> Either a b
Left Builder
ws) Maybe Text
anc Tag
tag (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder
doEol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
g' [Event]
xs
      where
        g' :: [Event] -> Builder
g' (MappingEnd : rest :: [Event]
rest) = [Event] -> Builder
cont [Event]
rest                    -- All comments should be part of the key
        g' ys :: [Event]
ys                  = Builder
pfx Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> ([Event] -> Builder) -> Builder
putKey [Event]
ys [Event] -> Builder
putValue'

        g :: [Event] -> Builder
g (Comment com :: Text
com: rest :: [Event]
rest) = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment Int
n Bool
True Context
c' Text
com ([Event] -> Builder
g [Event]
rest)  -- For trailing comments
        g (MappingEnd : rest :: [Event]
rest) = [Event] -> Builder
cont [Event]
rest
        g ys :: [Event]
ys                  = Builder
pfx Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> ([Event] -> Builder) -> Builder
putKey [Event]
ys [Event] -> Builder
putValue'

        pfx :: Builder
pfx = if Context
c Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
BlockIn Bool -> Bool -> Bool
|| Context
c Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
BlockOut Bool -> Bool -> Bool
|| Context
c Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
BlockKey then Int -> Builder
mkInd Int
n else Builder
ws
        c' :: Context
c' = if Context
FlowIn Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
c then Context
FlowKey else Context
BlockKey

        doEol :: Builder
doEol = case Context
c of
          FlowKey -> Builder
forall a. Monoid a => a
mempty
          FlowIn  -> Builder
forall a. Monoid a => a
mempty
          _       -> Builder
eol

        putKey :: [Event] -> ([Event] -> Builder) -> Builder
putKey zs :: [Event]
zs cont2 :: [Event] -> Builder
cont2
          | [Event] -> Bool
isSmallKey [Event]
zs = Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0) Context
c' [Event]
zs (\ys :: [Event]
ys -> ":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont2 [Event]
ys)
          | Comment com :: Text
com: rest :: [Event]
rest <- [Event]
zs = "?" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
ws Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> Context -> Text -> Builder -> Builder
goComment 0 Bool
True Context
BlockIn Text
com ([Event] -> ([Event] -> Builder) -> Builder
f [Event]
rest [Event] -> Builder
cont2)
          | Bool
otherwise     = "?" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n Bool
False Context
BlockIn [Event]
zs (([Event] -> Builder) -> [Event] -> Builder
forall t. (t -> Builder) -> t -> Builder
putValue [Event] -> Builder
cont2)

        f :: [Event] -> ([Event] -> Builder) -> Builder
f (Comment com :: Text
com: rest :: [Event]
rest) cont2 :: [Event] -> Builder
cont2 = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Bool
True Context
BlockIn Text
com ([Event] -> ([Event] -> Builder) -> Builder
f [Event]
rest [Event] -> Builder
cont2)   -- Comments should not change position in key
        f zs :: [Event]
zs cont2 :: [Event] -> Builder
cont2                  = Builder
ws Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd Int
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n Bool
False Context
BlockIn [Event]
zs (([Event] -> Builder) -> [Event] -> Builder
forall t. (t -> Builder) -> t -> Builder
putValue [Event] -> Builder
cont2)

        putValue :: (t -> Builder) -> t -> Builder
putValue cont2 :: t -> Builder
cont2 zs :: t
zs
          | Context
FlowIn <- Context
c   = Builder
ws Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> t -> Builder
cont2 t
zs
          | Bool
otherwise     = Int -> Builder
mkInd Int
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> t -> Builder
cont2 t
zs

        putValue' :: [Event] -> Builder
putValue' (Comment com :: Text
com: rest :: [Event]
rest) = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Bool
False Context
BlockOut Text
com (Builder
ws Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
putValue' [Event]
rest) -- Comments should not change position in value
        putValue' zs :: [Event]
zs = Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n Bool
False (if Context
FlowIn Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
c then Context
FlowIn else Context
BlockOut) [Event]
zs [Event] -> Builder
g

    goMap n :: Int
n sol :: Bool
sol c :: Context
c anc :: Maybe Text
anc tag :: Tag
tag Flow xs :: [Event]
xs cont :: [Event] -> Builder
cont =
        Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' (Builder -> Either Builder Builder
forall a b. b -> Either a b
Right Builder
ws) Maybe Text
anc Tag
tag ("{" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
f [Event]
xs)
          where
            f :: [Event] -> Builder
f (Comment com :: Text
com: rest :: [Event]
rest) = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> Context -> Text -> Builder -> Builder
goComment Int
n' Bool
True (Context -> Context
inFlow Context
c) Text
com ([Event] -> Builder
f [Event]
rest)
            f (MappingEnd : rest :: [Event]
rest) = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "}" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
doEol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont [Event]
rest
            f ys :: [Event]
ys                  = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd Int
n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> ([Event] -> Builder) -> Builder
putKey [Event]
ys [Event] -> Builder
putValue'

            n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

            doEol :: Builder
doEol = case Context
c of
              FlowKey -> Builder
forall a. Monoid a => a
mempty
              FlowIn  -> Builder
forall a. Monoid a => a
mempty
              _       -> Builder
eol

            g :: [Event] -> Builder
g (Comment com :: Text
com: rest :: [Event]
rest) = "," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> Context -> Text -> Builder -> Builder
goComment Int
n' Bool
True (Context -> Context
inFlow Context
c) Text
com ([Event] -> Builder
f [Event]
rest)
            g (MappingEnd : rest :: [Event]
rest) = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "}" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
doEol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont [Event]
rest
            g ys :: [Event]
ys                  = "," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd Int
n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> ([Event] -> Builder) -> Builder
putKey [Event]
ys [Event] -> Builder
putValue'

            putKey :: [Event] -> ([Event] -> Builder) -> Builder
putKey zs :: [Event]
zs cont2 :: [Event] -> Builder
cont2
              | (Comment com :: Text
com: rest :: [Event]
rest) <- [Event]
zs = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment Int
n' Bool
True Context
c Text
com (Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd Int
n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> ([Event] -> Builder) -> Builder
putKey [Event]
rest [Event] -> Builder
cont2)
              | [Event] -> Bool
isSmallKey [Event]
zs =    Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n' (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0) Context
FlowKey [Event]
zs (if [Event] -> Bool
isComEv [Event]
zs then ([Event] -> Builder) -> [Event] -> Builder
putValue [Event] -> Builder
cont2 else (\ys :: [Event]
ys -> ":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont2 [Event]
ys))
              | Bool
otherwise     = "?" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n Bool
False Context
FlowIn [Event]
zs (([Event] -> Builder) -> [Event] -> Builder
putValue [Event] -> Builder
cont2)

            putValue :: ([Event] -> Builder) -> [Event] -> Builder
putValue cont2 :: [Event] -> Builder
cont2 zs :: [Event]
zs
              | Comment com :: Text
com: rest :: [Event]
rest <- [Event]
zs =  Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> Context -> Text -> Builder -> Builder
goComment Int
n' Bool
True (Context -> Context
inFlow Context
c) Text
com (([Event] -> Builder) -> [Event] -> Builder
putValue [Event] -> Builder
cont2 [Event]
rest)
              | Bool
otherwise     = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd Int
n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont2 [Event]
zs

            putValue' :: [Event] -> Builder
putValue' zs :: [Event]
zs
              | Comment com :: Text
com : rest :: [Event]
rest <- [Event]
zs = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment Int
n' Bool
False Context
FlowOut Text
com ([Event] -> Builder
putValue' [Event]
rest)
              | Bool
otherwise = Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n' Bool
False Context
FlowIn [Event]
zs [Event] -> Builder
g


    goSeq :: Int
-> Bool
-> Context
-> Maybe Text
-> Tag
-> NodeStyle
-> [Event]
-> ([Event] -> Builder)
-> Builder
goSeq _ sol :: Bool
sol _ anc :: Maybe Text
anc tag :: Tag
tag _ (SequenceEnd : rest :: [Event]
rest) cont :: [Event] -> Builder
cont = Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ "[]\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont [Event]
rest
      where
        pfx :: Builder -> Builder
pfx cont' :: Builder
cont' = Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' (Builder -> Either Builder Builder
forall a b. b -> Either a b
Right Builder
ws) Maybe Text
anc Tag
tag Builder
cont'

    goSeq n :: Int
n sol :: Bool
sol c :: Context
c anc :: Maybe Text
anc tag :: Tag
tag Block xs :: [Event]
xs cont :: [Event] -> Builder
cont = case Context
c of
        BlockOut -> Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' (Builder -> Either Builder Builder
forall a b. a -> Either a b
Left Builder
ws) Maybe Text
anc Tag
tag (Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> if [Event] -> Bool
isComEv [Event]
xs then "-" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
f [Event]
xs else [Event] -> Builder
g [Event]
xs)

        BlockIn
          | Bool -> Bool
not Bool
sol Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 {- "---" case -} -> Int
-> Bool
-> Context
-> Maybe Text
-> Tag
-> NodeStyle
-> [Event]
-> ([Event] -> Builder)
-> Builder
goSeq Int
n Bool
sol Context
BlockOut Maybe Text
anc Tag
tag NodeStyle
Block [Event]
xs [Event] -> Builder
cont
          | Comment com :: Text
com: rest :: [Event]
rest <- [Event]
xs ->  Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' (Builder -> Either Builder Builder
forall a b. b -> Either a b
Right (Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd Int
n')) Maybe Text
anc Tag
tag ("-" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
ws Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> Context -> Text -> Builder -> Builder
goComment 0 Bool
True Context
BlockIn Text
com ([Event] -> Builder
f [Event]
rest))
          | Bool
otherwise -> Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' (Builder -> Either Builder Builder
forall a b. b -> Either a b
Right (Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd Int
n')) Maybe Text
anc Tag
tag ("-" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n' Bool
False Context
BlockIn [Event]
xs [Event] -> Builder
g)

        BlockKey -> [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error "sequence in block-key context not supported"

        _ -> [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error "Invalid Context in Block style"

      where
        n' :: Int
n' | Context
BlockOut <- Context
c = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
           | Bool
otherwise     = Int
n

        g :: [Event] -> Builder
g (Comment com :: Text
com: rest :: [Event]
rest)  = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment Int
n' Bool
True Context
BlockIn Text
com ([Event] -> Builder
g [Event]
rest)
        g (SequenceEnd : rest :: [Event]
rest) = [Event] -> Builder
cont [Event]
rest
        g ys :: [Event]
ys                   = Int -> Builder
mkInd Int
n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "-" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n' Bool
False Context
BlockIn [Event]
ys [Event] -> Builder
g

        f :: [Event] -> Builder
f (Comment com :: Text
com: rest :: [Event]
rest)  = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment Int
n' Bool
True Context
BlockIn Text
com ([Event] -> Builder
f [Event]
rest)
        f (SequenceEnd : rest :: [Event]
rest) = [Event] -> Builder
cont [Event]
rest
        f ys :: [Event]
ys                   = Builder
ws Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd Int
n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n' Bool
False Context
BlockIn [Event]
ys [Event] -> Builder
g

    goSeq n :: Int
n sol :: Bool
sol c :: Context
c anc :: Maybe Text
anc tag :: Tag
tag Flow xs :: [Event]
xs cont :: [Event] -> Builder
cont =
      Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' (Builder -> Either Builder Builder
forall a b. b -> Either a b
Right Builder
ws) Maybe Text
anc Tag
tag ("[" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
f [Event]
xs)
        where
          f :: [Event] -> Builder
f (Comment com :: Text
com: rest :: [Event]
rest)  = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> Context -> Text -> Builder -> Builder
goComment Int
n' Bool
True (Context -> Context
inFlow Context
c) Text
com ([Event] -> Builder
f [Event]
rest)
          f (SequenceEnd : rest :: [Event]
rest) = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "]" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
doEol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont [Event]
rest
          f ys :: [Event]
ys                   = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd Int
n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n' Bool
False (Context -> Context
inFlow Context
c) [Event]
ys [Event] -> Builder
g

          n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

          doEol :: Builder
doEol = case Context
c of
            FlowKey -> Builder
forall a. Monoid a => a
mempty
            FlowIn  -> Builder
forall a. Monoid a => a
mempty
            _       -> Builder
eol

          g :: [Event] -> Builder
g (Comment com :: Text
com: rest :: [Event]
rest)  = "," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> Context -> Text -> Builder -> Builder
goComment Int
n' Bool
True (Context -> Context
inFlow Context
c) Text
com ([Event] -> Builder
f [Event]
rest)
          g (SequenceEnd : rest :: [Event]
rest) = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
wsSol Bool
sol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "]" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
doEol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont [Event]
rest
          g ys :: [Event]
ys                   = "," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd Int
n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go Int
n' Bool
False (Context -> Context
inFlow Context
c) [Event]
ys [Event] -> Builder
g


    goAlias :: Context -> Text -> Builder -> Builder
goAlias c :: Context
c a :: Text
a cont :: Builder
cont = Char -> Builder
T.B.singleton '*' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
T.B.fromText Text
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont
      where
        sep :: Builder
sep = case Context
c of
          BlockIn  -> Builder
eol
          BlockOut -> Builder
eol
          BlockKey -> Char -> Builder
T.B.singleton ' '
          FlowIn   -> Builder
forall a. Monoid a => a
mempty
          FlowOut  -> Builder
eol
          FlowKey  -> Char -> Builder
T.B.singleton ' '

    goStr :: Int -> Bool -> Context -> Maybe Anchor -> Tag -> ScalarStyle -> Text -> T.B.Builder -> T.B.Builder
    goStr :: Int
-> Bool
-> Context
-> Maybe Text
-> Tag
-> ScalarStyle
-> Text
-> Builder
-> Builder
goStr !Int
n !Bool
sol c :: Context
c anc :: Maybe Text
anc tag :: Tag
tag sty :: ScalarStyle
sty t :: Text
t cont :: Builder
cont = case ScalarStyle
sty of
      -- flow-style

      Plain -- empty scalars
        | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "" -> case () of
                      _ | Maybe Text
Nothing <- Maybe Text
anc, Tag Nothing <- Tag
tag  -> Builder
contEol -- not even node properties
                        | Bool
sol                                 -> Maybe Text -> Tag -> Builder -> Builder
anchorTag0 Maybe Text
anc Tag
tag (if Context
c Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
BlockKey Bool -> Bool -> Bool
|| Context
c Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
FlowKey then Builder
ws Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont else Builder
contEol)
                        | Context
BlockKey <- Context
c                       -> Maybe Text -> Tag -> Builder -> Builder
anchorTag0 Maybe Text
anc Tag
tag (Builder
ws Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont)
                        | Context
FlowKey <- Context
c                        -> Maybe Text -> Tag -> Builder -> Builder
anchorTag0 Maybe Text
anc Tag
tag (Builder
ws Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont)
                        | Bool
otherwise                           -> Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' (Builder -> Either Builder Builder
forall a b. a -> Either a b
Left Builder
ws) Maybe Text
anc Tag
tag Builder
contEol

      Plain           -> Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
                          let h :: [Text] -> Builder
h []     = Builder
contEol
                              h (x :: Text
x:xs :: [Text]
xs) = Text -> Builder
T.B.fromText Text
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder
f' [Text]
xs
                                where
                                  f' :: [Text] -> Builder
f' []     = Builder
contEol
                                  f' (y :: Text
y:ys :: [Text]
ys) = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
T.B.fromText Text
y Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder
f' [Text]
ys
                          in [Text] -> Builder
h ([Text] -> [Text]
insFoldNls (Text -> [Text]
T.lines Text
t)) -- FIXME: unquoted plain-strings can't handle leading/trailing whitespace properly

      SingleQuoted    -> Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Char -> Builder
T.B.singleton '\'' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder -> Builder
f ([Text] -> [Text]
insFoldNls ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines (Text -> Text -> Text -> Text
T.replace "'" "''" Text
t) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [ Text
forall a. Monoid a => a
mempty | Text -> Text -> Bool
T.isSuffixOf "\n" Text
t]) (Char -> Builder
T.B.singleton '\'' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
contEol) -- FIXME: leading white-space (i.e. SPC) before/after LF

      DoubleQuoted    -> Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Char -> Builder
T.B.singleton '"'  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
T.B.fromText (Text -> Text
escapeDQ Text
t) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
T.B.singleton '"'  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
contEol

      -- block style
      Folded chm :: Chomp
chm iden :: IndentOfs
iden -> Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ ">" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Chomp -> Builder
goChomp Chomp
chm Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> IndentOfs -> Builder
goDigit IndentOfs
iden Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Int -> Builder -> Builder
g ([Text] -> [Text]
insFoldNls' ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
t) (IndentOfs -> Int
forall a. Enum a => a -> Int
fromEnum IndentOfs
iden) Builder
cont

      Literal chm :: Chomp
chm iden :: IndentOfs
iden -> Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ "|" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Chomp -> Builder
goChomp Chomp
chm Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> IndentOfs -> Builder
goDigit IndentOfs
iden Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Int -> Builder -> Builder
g (Text -> [Text]
T.lines Text
t) (IndentOfs -> Int
forall a. Enum a => a -> Int
fromEnum IndentOfs
iden) Builder
cont

      where
        goDigit :: IndentOfs -> T.B.Builder
        goDigit :: IndentOfs -> Builder
goDigit iden :: IndentOfs
iden = let ch :: Char
ch = Int -> Char
C.intToDigit(Int -> Char) -> (IndentOfs -> Int) -> IndentOfs -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
.IndentOfs -> Int
forall a. Enum a => a -> Int
fromEnum (IndentOfs -> Char) -> IndentOfs -> Char
forall a b. (a -> b) -> a -> b
$ IndentOfs
iden
                       in if(Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '0') then Builder
forall a. Monoid a => a
mempty else Char -> Builder
T.B.singleton Char
ch

        goChomp :: Chomp -> T.B.Builder
        goChomp :: Chomp -> Builder
goChomp chm :: Chomp
chm = case Chomp
chm of
           Strip -> Char -> Builder
T.B.singleton '-'
           Clip  -> Builder
forall a. Monoid a => a
mempty
           Keep  -> Char -> Builder
T.B.singleton '+'

        pfx :: Builder -> Builder
pfx cont' :: Builder
cont' = (if Bool
sol Bool -> Bool -> Bool
|| Context
c Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
BlockKey Bool -> Bool -> Bool
|| Context
c Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
FlowKey then Builder
forall a. Monoid a => a
mempty else Builder
ws) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' (Builder -> Either Builder Builder
forall a b. b -> Either a b
Right Builder
ws) Maybe Text
anc Tag
tag Builder
cont'

        doEol :: Bool
doEol = case Context
c of
          BlockKey -> Bool
False
          FlowKey  -> Bool
False
          FlowIn   -> Bool
False
          _        -> Bool
True

        contEol :: Builder
contEol
          | Bool
doEol     = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont
          | Bool
otherwise = Builder
cont

        g :: [Text] -> Int -> Builder -> Builder
g []     _ cont' :: Builder
cont' = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont'
        g (x :: Text
x:xs :: [Text]
xs) dig :: Int
dig cont' :: Builder
cont'
          | Text -> Bool
T.null Text
x   = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Int -> Builder -> Builder
g [Text]
xs Int
dig Builder
cont'
          | Int
dig Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0   = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 then Int -> Builder
mkInd Int
n else Int -> Builder
mkInd' 1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
T.B.fromText Text
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Int -> Builder -> Builder
g [Text]
xs Int
dig Builder
cont'
          | Bool
otherwise  = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd' Int
dig Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
T.B.fromText Text
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Int -> Builder -> Builder
g [Text]
xs Int
dig Builder
cont'

        g' :: [Text] -> Builder -> Builder
g' []     cont' :: Builder
cont' = Builder
cont'
        g' (x :: Text
x:xs :: [Text]
xs) cont' :: Builder
cont' = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
mkInd (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
T.B.fromText Text
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder -> Builder
g' [Text]
xs Builder
cont'

        f :: [Text] -> Builder -> Builder
f []     cont' :: Builder
cont' = Builder
cont'
        f (x :: Text
x:xs :: [Text]
xs) cont' :: Builder
cont' = Text -> Builder
T.B.fromText Text
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder -> Builder
g' [Text]
xs Builder
cont'


    isSmallKey :: [Event] -> Bool
isSmallKey (Alias _ : _)                   = Bool
True
    isSmallKey (Scalar _ _ (Folded _ _) _: _)  = Bool
False
    isSmallKey (Scalar _ _ (Literal _ _) _: _) = Bool
False
    isSmallKey (Scalar _ _ _ _ : _)            = Bool
True
    isSmallKey (SequenceStart _ _ _ : _)       = Bool
False
    isSmallKey (MappingStart _ _ _ : _)        = Bool
False
    isSmallKey _                               = Bool
False

    -- <https://yaml.org/spec/1.2/spec.html#in-flow(c) in-flow(c)>
    inFlow :: Context -> Context
inFlow c :: Context
c = case Context
c of
      FlowIn   -> Context
FlowIn
      FlowOut  -> Context
FlowIn
      BlockKey -> Context
FlowKey
      FlowKey  -> Context
FlowKey
      _        -> [Char] -> Context
forall a. HasCallStack => [Char] -> a
error "Invalid context in Flow style"


    putTag :: Text -> Builder -> Builder
putTag t :: Text
t cont :: Builder
cont
      | Just t' :: Text
t' <- Text -> Text -> Maybe Text
T.stripPrefix "tag:yaml.org,2002:" Text
t = "!!" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
T.B.fromText Text
t' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont
      | "!" Text -> Text -> Bool
`T.isPrefixOf` Text
t = Text -> Builder
T.B.fromText Text
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont
      | Bool
otherwise            = "!<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
T.B.fromText Text
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
T.B.singleton '>' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont

    anchorTag'' :: Either T.B.Builder T.B.Builder -> Maybe Anchor -> Tag -> T.B.Builder -> T.B.Builder
    anchorTag'' :: Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' _ Nothing (Tag Nothing) cont :: Builder
cont = Builder
cont
    anchorTag'' (Right pad :: Builder
pad) Nothing (Tag (Just t :: Text
t)) cont :: Builder
cont  = Text -> Builder -> Builder
putTag Text
t (Builder
pad Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont)
    anchorTag'' (Right pad :: Builder
pad) (Just a :: Text
a) (Tag Nothing) cont :: Builder
cont  = Char -> Builder
T.B.singleton '&' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
T.B.fromText Text
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
pad Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont
    anchorTag'' (Right pad :: Builder
pad) (Just a :: Text
a) (Tag (Just t :: Text
t)) cont :: Builder
cont = Char -> Builder
T.B.singleton '&' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
T.B.fromText Text
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
T.B.singleton ' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder -> Builder
putTag Text
t (Builder
pad Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont)
    anchorTag'' (Left pad :: Builder
pad)  Nothing (Tag (Just t :: Text
t)) cont :: Builder
cont  = Builder
pad Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder -> Builder
putTag Text
t Builder
cont
    anchorTag'' (Left pad :: Builder
pad)  (Just a :: Text
a) (Tag Nothing) cont :: Builder
cont  = Builder
pad Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
T.B.singleton '&' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
T.B.fromText Text
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont
    anchorTag'' (Left pad :: Builder
pad)  (Just a :: Text
a) (Tag (Just t :: Text
t)) cont :: Builder
cont = Builder
pad Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
T.B.singleton '&' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
T.B.fromText Text
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
T.B.singleton ' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder -> Builder
putTag Text
t Builder
cont

    anchorTag0 :: Maybe Text -> Tag -> Builder -> Builder
anchorTag0 = Either Builder Builder -> Maybe Text -> Tag -> Builder -> Builder
anchorTag'' (Builder -> Either Builder Builder
forall a b. a -> Either a b
Left Builder
forall a. Monoid a => a
mempty)
    -- anchorTag  = anchorTag'' (Right (T.B.singleton ' '))
    -- anchorTag' = anchorTag'' (Left (T.B.singleton ' '))

isComEv :: [Event] -> Bool
isComEv :: [Event] -> Bool
isComEv (Comment _: _) = Bool
True
isComEv _              = Bool
False

-- indentation helper
mkInd :: Int -> T.B.Builder
mkInd :: Int -> Builder
mkInd (-1) = Builder
forall a. Monoid a => a
mempty
mkInd 0    = Builder
forall a. Monoid a => a
mempty
mkInd 1 = "  "
mkInd 2 = "    "
mkInd 3 = "      "
mkInd 4 = "        "
mkInd l :: Int
l
  | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0     = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
l)
  | Bool
otherwise = Text -> Builder
T.B.fromText (Int -> Text -> Text
T.replicate Int
l "  ")

mkInd' :: Int -> T.B.Builder
mkInd' :: Int -> Builder
mkInd' 1 = " "
mkInd' 2 = "  "
mkInd' 3 = "   "
mkInd' 4 = "    "
mkInd' 5 = "     "
mkInd' 6 = "      "
mkInd' 7 = "       "
mkInd' 8 = "        "
mkInd' 9 = "         "
mkInd' l :: Int
l = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error ("Impossible Indentation-level" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
l)

eol, ws:: T.B.Builder
eol :: Builder
eol = Char -> Builder
T.B.singleton '\n'
ws :: Builder
ws  = Char -> Builder
T.B.singleton ' '

wsSol :: Bool -> T.B.Builder
wsSol :: Bool -> Builder
wsSol sol :: Bool
sol = if Bool
sol then Builder
forall a. Monoid a => a
mempty else Builder
ws

escapeDQ :: Text -> Text
escapeDQ :: Text -> Text
escapeDQ t :: Text
t
  | (Char -> Bool) -> Text -> Bool
T.all (\c :: Char
c -> Char -> Bool
C.isPrint Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\\' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '"') Text
t = Text
t
  | Bool
otherwise = (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
escapeChar Text
t

escapeChar :: Char -> Text
escapeChar :: Char -> Text
escapeChar c :: Char
c
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\\'   = "\\\\"
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '"'    = "\\\""
  | Char -> Bool
C.isPrint Char
c = Char -> Text
T.singleton Char
c
  | Just e :: Text
e <- Char -> Map Char Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
c Map Char Text
emap = Text
e
  | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0xff   = [Char] -> Text
T.pack ([Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf "\\x%02x" Int
x)
  | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0xffff = [Char] -> Text
T.pack ([Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf "\\u%04x" Int
x)
  | Bool
otherwise   = [Char] -> Text
T.pack ([Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf "\\U%08x" Int
x)
  where
    x :: Int
x = Char -> Int
ord Char
c

    emap :: Map Char Text
emap = [(Char, Text)] -> Map Char Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Char
v,[Char] -> Text
T.pack ['\\',Char
k]) | (k :: Char
k,v :: Char
v) <- [(Char, Char)]
escapes ]


escapes :: [(Char,Char)]
escapes :: [(Char, Char)]
escapes =
  [ ('0',   '\0')
  , ('a',   '\x7')
  , ('b',   '\x8')
  , ('\x9', '\x9')
  , ('t',   '\x9')
  , ('n',   '\xa')
  , ('v',   '\xb')
  , ('f',   '\xc')
  , ('r',   '\xd')
  , ('e',   '\x1b')
  , (' ',   ' ')
  , ('"',   '"')
  , ('/',   '/')
  , ('\\',  '\\')
  , ('N',   '\x85')
  , ('_',   '\xa0')
  , ('L',   '\x2028')
  , ('P',   '\x2029')
  ]


-- flow style line folding
-- FIXME: check single-quoted strings with leading '\n' or trailing '\n's
insFoldNls :: [Text] -> [Text]
insFoldNls :: [Text] -> [Text]
insFoldNls [] = []
insFoldNls z0 :: [Text]
z0@(z :: Text
z:zs :: [Text]
zs)
  | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Text -> Bool
T.null [Text]
z0     = "" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
z0 -- HACK
  | Bool
otherwise         = Text
z Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
go [Text]
zs
  where
    go :: [Text] -> [Text]
go [] = []
    go (l :: Text
l:ls :: [Text]
ls)
      | Text -> Bool
T.null Text
l = Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
go'  [Text]
ls
      | Bool
otherwise = "" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
go  [Text]
ls

    go' :: [Text] -> [Text]
go' [] = [""]
    go' (l :: Text
l:ls :: [Text]
ls)
      | Text -> Bool
T.null Text
l = Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
go' [Text]
ls
      | Bool
otherwise = "" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
go  [Text]
ls

{- block style line folding

The combined effect of the block line folding rules is that each
“paragraph” is interpreted as a line, empty lines are interpreted as a
line feed, and the formatting of more-indented lines is preserved.

-}
insFoldNls' :: [Text] -> [Text]
insFoldNls' :: [Text] -> [Text]
insFoldNls' = [Text] -> [Text]
go'
  where
    go :: [Text] -> [Text]
go []                  = []
    go (l :: Text
l:ls :: [Text]
ls)
      | Text -> Bool
T.null Text
l           = Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
go  [Text]
ls
      | Char -> Bool
isWhite (Text -> Char
T.head Text
l) = Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
go' [Text]
ls
      | Bool
otherwise          = "" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
go  [Text]
ls

    go' :: [Text] -> [Text]
go' []                 = []
    go' (l :: Text
l:ls :: [Text]
ls)
      | Text -> Bool
T.null Text
l           = Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
go' [Text]
ls
      | Char -> Bool
isWhite (Text -> Char
T.head Text
l) = Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
go' [Text]
ls
      | Bool
otherwise          = Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
go [Text]
ls

    -- @s-white@
    isWhite :: Char -> Bool
    isWhite :: Char -> Bool
isWhite ' '  = Bool
True
    isWhite '\t' = Bool
True
    isWhite _    = Bool
False