{-# OPTIONS_HADDOCK not-home #-}

-- | The renderer of the nodes of the encoder.
--
-- This module is intended for internal use only, and may change without warning
-- in subsequent releases.
module Yamlet.Internal.Encoder
  ( renderDocuments
  ) where

import Data.Maybe
import Data.Text qualified as T
import Data.Text.Builder.Linear qualified as B

import Yamlet.Internal.Emit
import Yamlet.Internal.Render
import Yamlet.Internal.Syntax qualified as S
import Yamlet.Internal.Utils

-- | Render documents. Documents after the first one start with a @---@
-- marker. The collections of 'Yamlet.Encode.toYaml' are in the block style.
--
-- A document with comments, anchors, aliases, flow collections, scalars on
-- several lines or scalar styles that 'Yamlet.Encode.toYaml' does not create
-- goes to 'Yamlet.Syntax.renderSyntax'. Other documents go to a faster
-- renderer, which gives the same output.
renderDocuments :: [S.Node] -> T.Text
renderDocuments :: [Node] -> Text
renderDocuments [Node]
docs
  | (Node -> Bool) -> [Node] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Node -> Bool
simple [Node]
docs = Builder -> Text
Builder -> Text
B.runBuilder (Builder -> Text) -> ([Builder] -> Builder) -> [Builder] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Text) -> [Builder] -> Text
forall a b. (a -> b) -> a -> b
$ (Int -> Node -> Builder) -> [Int] -> [Node] -> [Builder]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Node -> Builder
document [Int
0 :: Int ..] [Node]
docs
  | Bool
otherwise = RenderOptions -> [Document] -> Text
renderSyntax RenderOptions
defaultRenderOptions ((Node -> Document) -> [Node] -> [Document]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Document
S.document [Node]
docs)
  where
    document :: Int -> S.Node -> B.Builder
    document :: Int -> Node -> Builder
document Int
i Node
n
      | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
handles = (if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Builder
"---\n" else Builder
forall a. Monoid a => a
mempty) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Node -> Builder
topLevel Node
n
      | Bool
otherwise =
          (if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Builder
"...\n" else Builder
forall a. Monoid a => a
mempty)
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Char -> Builder) -> [Char] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Char -> Builder
tagDirective [Char]
handles
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"---\n"
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Node -> Builder
topLevel Node
n
      where
        handles :: [Char]
        handles :: [Char]
handles = Node -> [Char]
tagHandles Node
n

    topLevel :: S.Node -> B.Builder
    topLevel :: Node -> Builder
topLevel Node
n = case Node
n.content of
      S.SequenceContent CollectionStyle
_ xs :: [Node]
xs@(Node
_ : [Node]
_) -> Node -> Builder
tagLine Node
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> [Node] -> Builder
blockSequence Int
0 Bool
True [Node]
xs
      S.MappingContent CollectionStyle
_ kvs :: [(Node, Node)]
kvs@((Node, Node)
_ : [(Node, Node)]
_) -> Node -> Builder
tagLine Node
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> [(Node, Node)] -> Builder
blockMapping Int
0 Bool
True [(Node, Node)]
kvs
      S.ScalarContent ScalarStyle
S.Literal Text
t
        | Text -> Bool
needsIndentIndicator Text
t -> Node -> Builder -> Builder
withTag Node
n (Text -> Builder
doubleQuoted Text
t) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
      Content
_ -> Int -> Node -> Builder
inlineValue Int
indentStep Node
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"

    -- A tag of a block collection takes a line of its own.
    tagLine :: S.Node -> B.Builder
    tagLine :: Node -> Builder
tagLine Node
n = case Node -> Maybe Builder
tagPrefix Node
n of
      Just Builder
t -> Builder
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
      Maybe Builder
Nothing -> Builder
forall a. Monoid a => a
mempty

-- | The node has no comments, anchors, aliases and flow collections, and its
-- scalars are on one line and have the styles that 'Yamlet.Encode.toYaml'
-- creates.
simple :: S.Node -> Bool
simple :: Node -> Bool
simple Node
n =
  [Line] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Node
n.comments.before
    Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Node
n.comments.inline
    Bool -> Bool -> Bool
&& [Line] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Node
n.comments.after
    Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Node
n.props.anchor
    Bool -> Bool -> Bool
&& Node
n.props.tag Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
/= Tag
S.NonSpecificTag
    Bool -> Bool -> Bool
&& case Node
n.content of
      S.ScalarLinesContent ScalarStyle
_ Text
_ (Int
_ : [Int]
_) -> Bool
False
      -- The renderer gives an empty plain scalar no text.
      S.ScalarContent ScalarStyle
S.Plain Text
t -> Bool -> Bool
not (Text -> Bool
T.null Text
t)
      S.ScalarContent ScalarStyle
S.SingleQuoted Text
_ -> Bool
True
      S.ScalarContent ScalarStyle
S.DoubleQuoted Text
_ -> Bool
True
      S.ScalarContent ScalarStyle
S.Literal Text
_ -> Bool
True
      S.ScalarContent ScalarStyle
_ Text
_ -> Bool
False
      S.SequenceContent CollectionStyle
style [Node]
xs -> (CollectionStyle
style CollectionStyle -> CollectionStyle -> Bool
forall a. Eq a => a -> a -> Bool
== CollectionStyle
S.Block Bool -> Bool -> Bool
|| [Node] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node]
xs) Bool -> Bool -> Bool
&& (Node -> Bool) -> [Node] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Node -> Bool
simple [Node]
xs
      S.MappingContent CollectionStyle
style [(Node, Node)]
kvs ->
        (CollectionStyle
style CollectionStyle -> CollectionStyle -> Bool
forall a. Eq a => a -> a -> Bool
== CollectionStyle
S.Block Bool -> Bool -> Bool
|| [(Node, Node)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Node, Node)]
kvs) Bool -> Bool -> Bool
&& ((Node, Node) -> Bool) -> [(Node, Node)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Node
k, Node
v) -> Node -> Bool
simple Node
k Bool -> Bool -> Bool
&& Node -> Bool
simple Node
v) [(Node, Node)]
kvs
      S.AliasContent Text
_ -> Bool
False

-- | A block sequence of the items of a 'simple' node. The first entry does
-- not start with indentation if the sequence continues a line.
blockSequence :: Int -> Bool -> [S.Node] -> B.Builder
blockSequence :: Int -> Bool -> [Node] -> Builder
blockSequence Int
indent Bool
atLineStart = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Node] -> [Builder]) -> [Node] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Node -> Builder) -> [Int] -> [Node] -> [Builder]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Node -> Builder
entry [Int
0 :: Int ..]
  where
    entry :: Int -> S.Node -> B.Builder
    entry :: Int -> Node -> Builder
entry Int
i Node
x =
      (if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| Bool
atLineStart then Int -> Builder
spaces Int
indent else Builder
forall a. Monoid a => a
mempty)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"-"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Node -> Builder
afterIndicator Int
indent Node
x

-- | A node after the indicator of a sequence item or an explicit entry at the
-- given indentation, with the line break. A block collection starts on the
-- line of the indicator, unless it has a tag.
afterIndicator :: Int -> S.Node -> B.Builder
afterIndicator :: Int -> Node -> Builder
afterIndicator Int
indent Node
x = case Node
x.content of
  S.SequenceContent CollectionStyle
_ xs :: [Node]
xs@(Node
_ : [Node]
_) ->
    Builder -> Builder
collection (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> [Node] -> Builder
blockSequence (Int
indent Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
indentStep) Bool
False [Node]
xs
  S.MappingContent CollectionStyle
_ kvs :: [(Node, Node)]
kvs@((Node, Node)
_ : [(Node, Node)]
_) ->
    Builder -> Builder
collection (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> [(Node, Node)] -> Builder
blockMapping (Int
indent Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
indentStep) Bool
False [(Node, Node)]
kvs
  Content
_ -> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Node -> Builder
inlineValue (Int
indent Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
indentStep) Node
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
  where
    collection :: B.Builder -> B.Builder
    collection :: Builder -> Builder
collection Builder
body = case Node -> Maybe Builder
tagPrefix Node
x of
      Just Builder
t -> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
spaces (Int
indent Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
indentStep) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
body
      Maybe Builder
Nothing -> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
body

-- | A block mapping of the entries of a 'simple' node. The first entry does
-- not start with indentation if the mapping continues a line.
blockMapping :: Int -> Bool -> [(S.Node, S.Node)] -> B.Builder
blockMapping :: Int -> Bool -> [(Node, Node)] -> Builder
blockMapping Int
indent Bool
atLineStart = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([(Node, Node)] -> [Builder]) -> [(Node, Node)] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> (Node, Node) -> Builder)
-> [Int] -> [(Node, Node)] -> [Builder]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (Node, Node) -> Builder
entry [Int
0 :: Int ..]
  where
    entry :: Int -> (S.Node, S.Node) -> B.Builder
    entry :: Int -> (Node, Node) -> Builder
entry Int
i (Node
k, Node
v) =
      (if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| Bool
atLineStart then Int -> Builder
spaces Int
indent else Builder
forall a. Monoid a => a
mempty) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> case Node -> Maybe Builder
implicitKey Node
k of
        Just Builder
key -> Builder
key Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Node -> Builder
value Node
v
        Maybe Builder
Nothing ->
          Builder
"?"
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Node -> Builder
afterIndicator Int
indent Node
k
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
spaces Int
indent
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":"
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Node -> Builder
afterIndicator Int
indent Node
v

    value :: S.Node -> B.Builder
    value :: Node -> Builder
value Node
v = case Node
v.content of
      S.SequenceContent CollectionStyle
_ xs :: [Node]
xs@(Node
_ : [Node]
_) -> Node -> Builder
tagged Node
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> [Node] -> Builder
blockSequence Int
indent Bool
True [Node]
xs
      S.MappingContent CollectionStyle
_ kvs :: [(Node, Node)]
kvs@((Node, Node)
_ : [(Node, Node)]
_) ->
        Node -> Builder
tagged Node
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Bool -> [(Node, Node)] -> Builder
blockMapping (Int
indent Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
indentStep) Bool
True [(Node, Node)]
kvs
      Content
_ -> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Node -> Builder
inlineValue (Int
indent Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
indentStep) Node
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"

    tagged :: S.Node -> B.Builder
    tagged :: Node -> Builder
tagged Node
x = Builder -> (Builder -> Builder) -> Maybe Builder -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty (Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Node -> Maybe Builder
tagPrefix Node
x)

    -- A key that fits on one line, or 'Nothing' if it needs an explicit entry.
    implicitKey :: S.Node -> Maybe B.Builder
    implicitKey :: Node -> Maybe Builder
implicitKey Node
k = case Node
k.content of
      S.ScalarContent ScalarStyle
style Text
t
        | Tag
S.NoTag <- Node
k.props.tag
        , ScalarStyle
style ScalarStyle -> ScalarStyle -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarStyle
S.Plain
        , Bool -> Text -> Bool
plainSyntax Bool
False Text
t ->
            if Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxImplicitKeyLength then Maybe Builder
forall a. Maybe a
Nothing else Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Text -> Builder
B.fromText Text
t)
        | Bool
otherwise -> Builder -> Maybe Builder
fits (Node -> Builder -> Builder
withTag Node
k (ScalarStyle -> Text -> Builder
scalarText ScalarStyle
style Text
t))
      -- go-yaml v2 reads "[]: a" and "{}: a" without an error, but as an
      -- empty list or mapping, and drops the entries after them. A tag
      -- avoids that.
      S.SequenceContent CollectionStyle
_ [] | Maybe Builder -> Bool
forall a. Maybe a -> Bool
isJust (Node -> Maybe Builder
tagPrefix Node
k) -> Builder -> Maybe Builder
fits (Int -> Node -> Builder
inlineValue Int
0 Node
k)
      S.MappingContent CollectionStyle
_ [] | Maybe Builder -> Bool
forall a. Maybe a -> Bool
isJust (Node -> Maybe Builder
tagPrefix Node
k) -> Builder -> Maybe Builder
fits (Int -> Node -> Builder
inlineValue Int
0 Node
k)
      Content
_ -> Maybe Builder
forall a. Maybe a
Nothing
      where
        fits :: B.Builder -> Maybe B.Builder
        fits :: Builder -> Maybe Builder
fits Builder
key =
          if Text -> Int
T.length (Builder -> Text
Builder -> Text
B.runBuilder Builder
key) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxImplicitKeyLength then Maybe Builder
forall a. Maybe a
Nothing else Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
key

-- | A scalar, or an empty collection in the flow style.
inlineValue :: Int -> S.Node -> B.Builder
inlineValue :: Int -> Node -> Builder
inlineValue Int
indent Node
n = Node -> Builder -> Builder
withTag Node
n (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ case Node
n.content of
  S.SequenceContent CollectionStyle
_ [Node]
_ -> Builder
"[]"
  S.MappingContent CollectionStyle
_ [(Node, Node)]
_ -> Builder
"{}"
  S.ScalarContent ScalarStyle
S.Literal Text
t | Just (Builder
h, Builder
b) <- Int -> Text -> Maybe (Builder, Builder)
literalBlock Int
indent Text
t -> Builder
h Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b
  S.ScalarContent ScalarStyle
style Text
t -> ScalarStyle -> Text -> Builder
scalarText ScalarStyle
style Text
t
  S.AliasContent Text
_ -> Builder
forall a. Monoid a => a
mempty

-- | Prefix the tag if the node has one.
withTag :: S.Node -> B.Builder -> B.Builder
withTag :: Node -> Builder -> Builder
withTag Node
n Builder
b = case Node -> Maybe Builder
tagPrefix Node
n of
  Just Builder
t -> Builder
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b
  Maybe Builder
Nothing -> Builder
b

tagPrefix :: S.Node -> Maybe B.Builder
tagPrefix :: Node -> Maybe Builder
tagPrefix Node
n = case Node
n.props.tag of
  S.Tag Text
t -> Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Text -> Builder
tagText Text
t)
  Tag
_ -> Maybe Builder
forall a. Maybe a
Nothing

-- | A scalar of a 'simple' node on one line.
scalarText :: S.ScalarStyle -> T.Text -> B.Builder
scalarText :: ScalarStyle -> Text -> Builder
scalarText ScalarStyle
style Text
t = case ScalarStyle
style of
  ScalarStyle
S.Plain
    | Bool -> Text -> Bool
plainSyntax Bool
False Text
t -> Text -> Builder
B.fromText Text
t
    | Bool
otherwise -> Text -> Builder
quotedPlain Text
t
  ScalarStyle
S.SingleQuoted -> Builder
quoted
  ScalarStyle
_ -> Text -> Builder
doubleQuoted Text
t
  where
    quoted :: B.Builder
    quoted :: Builder
quoted = Builder -> Maybe Builder -> Builder
forall a. a -> Maybe a -> a
fromMaybe (Text -> Builder
doubleQuoted Text
t) (Text -> Maybe Builder
singleQuoted Text
t)