{-# 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 Encoding
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 Encoding
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 Char
'\xfeff' (Text -> Text) -> ([Event] -> Text) -> [Event] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Text
writeEventsText
writeEvents Encoding
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 Char
'\xfeff' (Text -> Text) -> ([Event] -> Text) -> [Event] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Text
writeEventsText
writeEvents Encoding
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 Char
'\xfeff' (Text -> Text) -> ([Event] -> Text) -> [Event] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Text
writeEventsText
writeEvents Encoding
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 Char
'\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 (Event
StreamStart:[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 (String -> Any
forall a. HasCallStack => String -> a
error String
"writeEvents: internal error")
  where
    -- goStream :: [Event] -> [Event] -> T.B.Builder
    goStream :: [Event] -> t -> Builder
goStream [Event
StreamEnd] t
_ = Builder
forall a. Monoid a => a
mempty
    goStream (Event
StreamEnd : Event
_ : [Event]
_ ) t
_cont = String -> Builder
forall a. HasCallStack => String -> a
error String
"writeEvents: events after StreamEnd"
    goStream (Comment Text
com: [Event]
rest) t
cont = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment (Int
0 :: Int) Bool
True Context
BlockIn Text
com ([Event] -> t -> Builder
goStream [Event]
rest t
cont)
    goStream (DocumentStart Directives
marker : [Event]
rest) t
cont
      = case Directives
marker of
          Directives
NoDirEndMarker         -> Bool -> [Event] -> ([Event] -> Builder) -> Builder
putNode Bool
False [Event]
rest (\[Event]
zs -> [Event] -> t -> Builder
goDoc [Event]
zs t
cont)
          Directives
DirEndMarkerNoVersion  -> Builder
"---" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> [Event] -> ([Event] -> Builder) -> Builder
putNode Bool
True [Event]
rest (\[Event]
zs -> [Event] -> t -> Builder
goDoc [Event]
zs t
cont)
          DirEndMarkerVersion Word
mi -> Builder
"%YAML 1." Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (String -> Builder
T.B.fromString (Word -> String
forall a. Show a => a -> String
show Word
mi)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n---" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> [Event] -> ([Event] -> Builder) -> Builder
putNode Bool
True [Event]
rest (\[Event]
zs -> [Event] -> t -> Builder
goDoc [Event]
zs t
cont)
    goStream (Event
x:[Event]
_) t
_cont = String -> Builder
forall a. HasCallStack => String -> a
error (String
"writeEvents: unexpected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Event -> String
forall a. Show a => a -> String
show Event
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (expected DocumentStart or StreamEnd)")
    goStream [] t
_cont = String -> Builder
forall a. HasCallStack => String -> a
error (String
"writeEvents: unexpected end of stream (expected DocumentStart or StreamEnd)")

    goDoc :: [Event] -> t -> Builder
goDoc (DocumentEnd Bool
marker : [Event]
rest) t
cont
      = (if Bool
marker then Builder
"...\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 Text
com: [Event]
rest) t
cont = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment (Int
0 :: Int) Bool
True Context
BlockIn Text
com ([Event] -> t -> Builder
goDoc [Event]
rest t
cont)
    goDoc [Event]
ys t
_ = String -> Builder
forall a. HasCallStack => String -> a
error ([Event] -> String
forall a. Show a => a -> String
show [Event]
ys)

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

writeEventsText (Event
x:[Event]
_) = String -> Text
forall a. HasCallStack => String -> a
error (String
"writeEvents: unexpected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Event -> String
forall a. Show a => a -> String
show Event
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (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 -> String -> String
[Context] -> String -> String
Context -> String
(Int -> Context -> String -> String)
-> (Context -> String)
-> ([Context] -> String -> String)
-> Show Context
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Context] -> String -> String
$cshowList :: [Context] -> String -> String
show :: Context -> String
$cshow :: Context -> String
showsPrec :: Int -> Context -> String -> String
$cshowsPrec :: Int -> Context -> String -> String
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 Context
c Text
comment Builder
cont = Builder
doSol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"#" 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
== Int
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 Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      | Context
FlowOut  <- Context
c = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 = \Bool
docMarker -> Int
-> Bool -> Context -> [Event] -> ([Event] -> Builder) -> Builder
go (-Int
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 Int
_  Bool
_ Context
_  [] [Event] -> Builder
_cont = String -> Builder
forall a. HasCallStack => String -> a
error (String
"putNode: expected node-start event instead of end-of-stream")
    go !Int
n !Bool
sol Context
c (Event
t : [Event]
rest) [Event] -> Builder
cont = case Event
t of
        Scalar        Maybe Text
anc Tag
tag ScalarStyle
sty Text
t' -> Int
-> Bool
-> Context
-> Maybe Text
-> Tag
-> ScalarStyle
-> Text
-> Builder
-> Builder
goStr (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Bool
sol Context
c Maybe Text
anc Tag
tag ScalarStyle
sty Text
t' ([Event] -> Builder
cont [Event]
rest)
        SequenceStart Maybe Text
anc Tag
tag 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
+Int
1) Bool
sol (NodeStyle -> Context
chn NodeStyle
sty) Maybe Text
anc Tag
tag NodeStyle
sty [Event]
rest [Event] -> Builder
cont
        MappingStart  Maybe Text
anc Tag
tag 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
+Int
1) Bool
sol (NodeStyle -> Context
chn NodeStyle
sty) Maybe Text
anc Tag
tag NodeStyle
sty [Event]
rest [Event] -> Builder
cont
        Alias 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 Text
com                  -> Int -> Bool -> Context -> Text -> Builder -> Builder
goComment (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
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)
        Event
_ -> String -> Builder
forall a. HasCallStack => String -> a
error (String
"putNode: expected node-start event instead of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Event -> String
forall a. Show a => a -> String
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 Char
' '

        chn :: NodeStyle -> Context
chn 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 Int
_ Bool
sol Context
_ Maybe Text
anc Tag
tag NodeStyle
_ (Event
MappingEnd : [Event]
rest) [Event] -> Builder
cont = Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder
"{}\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont [Event]
rest
      where
        pfx :: Builder -> Builder
pfx 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 Int
n Bool
sol Context
c Maybe Text
anc Tag
tag NodeStyle
Block [Event]
xs [Event] -> Builder
cont = case Context
c of
        Context
BlockIn | Bool -> Bool
not (Bool -> Bool
not Bool
sol Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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')
        Context
_  ->  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' (Event
MappingEnd : [Event]
rest) = [Event] -> Builder
cont [Event]
rest                    -- All comments should be part of the key
        g' [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 Text
com: [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 (Event
MappingEnd : [Event]
rest) = [Event] -> Builder
cont [Event]
rest
        g [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
          Context
FlowKey -> Builder
forall a. Monoid a => a
mempty
          Context
FlowIn  -> Builder
forall a. Monoid a => a
mempty
          Context
_       -> Builder
eol

        putKey :: [Event] -> ([Event] -> Builder) -> Builder
putKey [Event]
zs [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
== Int
0) Context
c' [Event]
zs (\[Event]
ys -> Builder
":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont2 [Event]
ys)
          | Comment Text
com: [Event]
rest <- [Event]
zs = Builder
"?" 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 Int
0 Bool
True Context
BlockIn Text
com ([Event] -> ([Event] -> Builder) -> Builder
f [Event]
rest [Event] -> Builder
cont2)
          | Bool
otherwise     = Builder
"?" 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 Text
com: [Event]
rest) [Event] -> Builder
cont2 = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 [Event]
zs [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 t -> Builder
cont2 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
- Int
1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":" 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 -> Builder
forall a. Semigroup a => a -> a -> a
<> t -> Builder
cont2 t
zs

        putValue' :: [Event] -> Builder
putValue' (Comment Text
com: [Event]
rest) = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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' [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 Int
n Bool
sol Context
c Maybe Text
anc Tag
tag NodeStyle
Flow [Event]
xs [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 -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
f [Event]
xs)
          where
            f :: [Event] -> Builder
f (Comment Text
com: [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 (Event
MappingEnd : [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
- Int
1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"}" 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 [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
+ Int
1

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

            g :: [Event] -> Builder
g (Comment Text
com: [Event]
rest) = Builder
"," 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 (Event
MappingEnd : [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
- Int
1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"}" 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 [Event]
ys                  = Builder
"," 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 [Event]
zs [Event] -> Builder
cont2
              | (Comment Text
com: [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
== Int
0) Context
FlowKey [Event]
zs (if [Event] -> Bool
isComEv [Event]
zs then ([Event] -> Builder) -> [Event] -> Builder
putValue [Event] -> Builder
cont2 else (\[Event]
ys -> Builder
":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont2 [Event]
ys))
              | Bool
otherwise     = Builder
"?" 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 [Event] -> Builder
cont2 [Event]
zs
              | Comment Text
com: [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 -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont2 [Event]
zs

            putValue' :: [Event] -> Builder
putValue' [Event]
zs
              | Comment Text
com : [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 Int
_ Bool
sol Context
_ Maybe Text
anc Tag
tag NodeStyle
_ (Event
SequenceEnd : [Event]
rest) [Event] -> Builder
cont = Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder
"[]\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
cont [Event]
rest
      where
        pfx :: Builder -> Builder
pfx 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 Int
n Bool
sol Context
c Maybe Text
anc Tag
tag NodeStyle
Block [Event]
xs [Event] -> Builder
cont = case Context
c of
        Context
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 -> 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)

        Context
BlockIn
          | Bool -> Bool
not Bool
sol Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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 Text
com: [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 -> 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 Int
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 -> 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)

        Context
BlockKey -> String -> Builder
forall a. HasCallStack => String -> a
error String
"sequence in block-key context not supported"

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

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

        g :: [Event] -> Builder
g (Comment Text
com: [Event]
rest)  = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment Int
n' Bool
True Context
BlockIn Text
com ([Event] -> Builder
g [Event]
rest)
        g (Event
SequenceEnd : [Event]
rest) = [Event] -> Builder
cont [Event]
rest
        g [Event]
ys                   = Int -> Builder
mkInd Int
n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"-" 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 Text
com: [Event]
rest)  = Int -> Bool -> Context -> Text -> Builder -> Builder
goComment Int
n' Bool
True Context
BlockIn Text
com ([Event] -> Builder
f [Event]
rest)
        f (Event
SequenceEnd : [Event]
rest) = [Event] -> Builder
cont [Event]
rest
        f [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 Int
n Bool
sol Context
c Maybe Text
anc Tag
tag NodeStyle
Flow [Event]
xs [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 -> Builder
forall a. Semigroup a => a -> a -> a
<> [Event] -> Builder
f [Event]
xs)
        where
          f :: [Event] -> Builder
f (Comment Text
com: [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 (Event
SequenceEnd : [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
- Int
1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"]" 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 [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
+ Int
1

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

          g :: [Event] -> Builder
g (Comment Text
com: [Event]
rest)  = Builder
"," 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 (Event
SequenceEnd : [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
- Int
1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"]" 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 [Event]
ys                   = Builder
"," 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 Context
c Text
a Builder
cont = Char -> Builder
T.B.singleton Char
'*' 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
          Context
BlockIn  -> Builder
eol
          Context
BlockOut -> Builder
eol
          Context
BlockKey -> Char -> Builder
T.B.singleton Char
' '
          Context
FlowIn   -> Builder
forall a. Monoid a => a
mempty
          Context
FlowOut  -> Builder
eol
          Context
FlowKey  -> Char -> Builder
T.B.singleton Char
' '

    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 Context
c Maybe Text
anc Tag
tag ScalarStyle
sty Text
t Builder
cont = case ScalarStyle
sty of
      -- flow-style

      ScalarStyle
Plain -- empty scalars
        | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" -> case () of
                      ()
_ | Maybe Text
Nothing <- Maybe Text
anc, Tag Maybe Text
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

      ScalarStyle
Plain           -> Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
                          let h :: [Text] -> Builder
h []     = Builder
contEol
                              h (Text
x:[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' (Text
y:[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
+Int
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

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

      ScalarStyle
DoubleQuoted    -> Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Char -> Builder
T.B.singleton Char
'"'  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 Char
'"'  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
contEol

      -- block style
      Folded Chomp
chm IndentOfs
iden -> Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder
">" 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 Chomp
chm IndentOfs
iden -> Builder -> Builder
pfx (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder
"|" 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 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
== Char
'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 Chomp
chm = case Chomp
chm of
           Chomp
Strip -> Char -> Builder
T.B.singleton Char
'-'
           Chomp
Clip  -> Builder
forall a. Monoid a => a
mempty
           Chomp
Keep  -> Char -> Builder
T.B.singleton Char
'+'

        pfx :: Builder -> Builder
pfx 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
          Context
BlockKey -> Bool
False
          Context
FlowKey  -> Bool
False
          Context
FlowIn   -> Bool
False
          Context
_        -> 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 []     Int
_ Builder
cont' = Builder
eol Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont'
        g (Text
x:[Text]
xs) Int
dig 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
== Int
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
> Int
0 then Int -> Builder
mkInd Int
n else Int -> Builder
mkInd' Int
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
-Int
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' []     Builder
cont' = Builder
cont'
        g' (Text
x:[Text]
xs) 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
+Int
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 []     Builder
cont' = Builder
cont'
        f (Text
x:[Text]
xs) 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 Text
_ : [Event]
_)                   = Bool
True
    isSmallKey (Scalar Maybe Text
_ Tag
_ (Folded Chomp
_ IndentOfs
_) Text
_: [Event]
_)  = Bool
False
    isSmallKey (Scalar Maybe Text
_ Tag
_ (Literal Chomp
_ IndentOfs
_) Text
_: [Event]
_) = Bool
False
    isSmallKey (Scalar Maybe Text
_ Tag
_ ScalarStyle
_ Text
_ : [Event]
_)            = Bool
True
    isSmallKey (SequenceStart Maybe Text
_ Tag
_ NodeStyle
_ : [Event]
_)       = Bool
False
    isSmallKey (MappingStart Maybe Text
_ Tag
_ NodeStyle
_ : [Event]
_)        = Bool
False
    isSmallKey [Event]
_                               = Bool
False

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


    putTag :: Text -> Builder -> Builder
putTag Text
t Builder
cont
      | Just Text
t' <- Text -> Text -> Maybe Text
T.stripPrefix Text
"tag:yaml.org,2002:" Text
t = Builder
"!!" 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 -> 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 -> 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 Char
'>' 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'' Either Builder Builder
_ Maybe Text
Nothing (Tag Maybe Text
Nothing) Builder
cont = Builder
cont
    anchorTag'' (Right Builder
pad) Maybe Text
Nothing (Tag (Just Text
t)) Builder
cont  = Text -> Builder -> Builder
putTag Text
t (Builder
pad Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cont)
    anchorTag'' (Right Builder
pad) (Just Text
a) (Tag Maybe Text
Nothing) Builder
cont  = Char -> Builder
T.B.singleton Char
'&' 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 Builder
pad) (Just Text
a) (Tag (Just Text
t)) Builder
cont = Char -> Builder
T.B.singleton Char
'&' 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 Char
' ' 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 Builder
pad)  Maybe Text
Nothing (Tag (Just Text
t)) Builder
cont  = Builder
pad Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder -> Builder
putTag Text
t Builder
cont
    anchorTag'' (Left Builder
pad)  (Just Text
a) (Tag Maybe Text
Nothing) Builder
cont  = Builder
pad Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
T.B.singleton Char
'&' 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 Builder
pad)  (Just Text
a) (Tag (Just Text
t)) Builder
cont = Builder
pad Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
T.B.singleton Char
'&' 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 Char
' ' 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 Text
_: [Event]
_) = Bool
True
isComEv [Event]
_              = Bool
False

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

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

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

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

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

escapeChar :: Char -> Text
escapeChar :: Char -> Text
escapeChar Char
c
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'   = Text
"\\\\"
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"'    = Text
"\\\""
  | Char -> Bool
C.isPrint Char
c = Char -> Text
T.singleton Char
c
  | Just 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
<= Int
0xff   = String -> Text
T.pack (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"\\x%02x" Int
x)
  | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xffff = String -> Text
T.pack (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"\\u%04x" Int
x)
  | Bool
otherwise   = String -> Text
T.pack (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"\\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,String -> Text
T.pack [Char
'\\',Char
k]) | (Char
k,Char
v) <- [(Char, Char)]
escapes ]


escapes :: [(Char,Char)]
escapes :: [(Char, Char)]
escapes =
  [ (Char
'0',   Char
'\0')
  , (Char
'a',   Char
'\x7')
  , (Char
'b',   Char
'\x8')
  , (Char
'\x9', Char
'\x9')
  , (Char
't',   Char
'\x9')
  , (Char
'n',   Char
'\xa')
  , (Char
'v',   Char
'\xb')
  , (Char
'f',   Char
'\xc')
  , (Char
'r',   Char
'\xd')
  , (Char
'e',   Char
'\x1b')
  , (Char
' ',   Char
' ')
  , (Char
'"',   Char
'"')
  , (Char
'/',   Char
'/')
  , (Char
'\\',  Char
'\\')
  , (Char
'N',   Char
'\x85')
  , (Char
'_',   Char
'\xa0')
  , (Char
'L',   Char
'\x2028')
  , (Char
'P',   Char
'\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@(Text
z:[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] -> [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 (Text
l:[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] -> [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' [] = [Text
""]
    go' (Text
l:[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] -> [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 (Text
l:[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] -> [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' (Text
l:[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 Char
' '  = Bool
True
    isWhite Char
'\t' = Bool
True
    isWhite Char
_    = Bool
False