Encoder.hs

{-# 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 docs
  | all simple docs = B.runBuilder . mconcat $ zipWith document [0 :: Int ..] docs
  | otherwise = renderSyntax defaultRenderOptions (map S.document docs)
  where
    document :: Int -> S.Node -> B.Builder
    document i n
      | null handles = (if i > 0 then "---\n" else mempty) <> topLevel n
      | otherwise =
          (if i > 0 then "...\n" else mempty)
            <> foldMap tagDirective handles
            <> "---\n"
            <> topLevel n
      where
        handles :: [Char]
        handles = tagHandles n

    topLevel :: S.Node -> B.Builder
    topLevel n = case n.content of
      S.SequenceContent _ xs@(_ : _) -> tagLine n <> blockSequence 0 True xs
      S.MappingContent _ kvs@(_ : _) -> tagLine n <> blockMapping 0 True kvs
      S.ScalarContent S.Literal t
        | needsIndentIndicator t -> withTag n (doubleQuoted t) <> "\n"
      _ -> inlineValue indentStep n <> "\n"

    -- A tag of a block collection takes a line of its own.
    tagLine :: S.Node -> B.Builder
    tagLine n = case tagPrefix n of
      Just t -> t <> "\n"
      Nothing -> 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 n =
  null n.comments.before
    && isNothing n.comments.inline
    && null n.comments.after
    && isNothing n.props.anchor
    && n.props.tag /= S.NonSpecificTag
    && case n.content of
      S.ScalarLinesContent _ _ (_ : _) -> False
      -- The renderer gives an empty plain scalar no text.
      S.ScalarContent S.Plain t -> not (T.null t)
      S.ScalarContent S.SingleQuoted _ -> True
      S.ScalarContent S.DoubleQuoted _ -> True
      S.ScalarContent S.Literal _ -> True
      S.ScalarContent _ _ -> False
      S.SequenceContent style xs -> (style == S.Block || null xs) && all simple xs
      S.MappingContent style kvs ->
        (style == S.Block || null kvs) && all (\(k, v) -> simple k && simple v) kvs
      S.AliasContent _ -> 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 indent atLineStart = mconcat . zipWith entry [0 :: Int ..]
  where
    entry :: Int -> S.Node -> B.Builder
    entry i x =
      (if i > 0 || atLineStart then spaces indent else mempty)
        <> "-"
        <> afterIndicator indent 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 indent x = case x.content of
  S.SequenceContent _ xs@(_ : _) ->
    collection $ blockSequence (indent + indentStep) False xs
  S.MappingContent _ kvs@(_ : _) ->
    collection $ blockMapping (indent + indentStep) False kvs
  _ -> " " <> inlineValue (indent + indentStep) x <> "\n"
  where
    collection :: B.Builder -> B.Builder
    collection body = case tagPrefix x of
      Just t -> " " <> t <> "\n" <> spaces (indent + indentStep) <> body
      Nothing -> " " <> 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 indent atLineStart = mconcat . zipWith entry [0 :: Int ..]
  where
    entry :: Int -> (S.Node, S.Node) -> B.Builder
    entry i (k, v) =
      (if i > 0 || atLineStart then spaces indent else mempty) <> case implicitKey k of
        Just key -> key <> ":" <> value v
        Nothing ->
          "?"
            <> afterIndicator indent k
            <> spaces indent
            <> ":"
            <> afterIndicator indent v

    value :: S.Node -> B.Builder
    value v = case v.content of
      S.SequenceContent _ xs@(_ : _) -> tagged v <> "\n" <> blockSequence indent True xs
      S.MappingContent _ kvs@(_ : _) ->
        tagged v <> "\n" <> blockMapping (indent + indentStep) True kvs
      _ -> " " <> inlineValue (indent + indentStep) v <> "\n"

    tagged :: S.Node -> B.Builder
    tagged x = maybe mempty (" " <>) (tagPrefix x)

    -- A key that fits on one line, or 'Nothing' if it needs an explicit entry.
    implicitKey :: S.Node -> Maybe B.Builder
    implicitKey k = case k.content of
      S.ScalarContent style t
        | S.NoTag <- k.props.tag
        , style == S.Plain
        , plainSyntax False t ->
            if T.length t > maxImplicitKeyLength then Nothing else Just (B.fromText t)
        | otherwise -> fits (withTag k (scalarText style 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 _ [] | isJust (tagPrefix k) -> fits (inlineValue 0 k)
      S.MappingContent _ [] | isJust (tagPrefix k) -> fits (inlineValue 0 k)
      _ -> Nothing
      where
        fits :: B.Builder -> Maybe B.Builder
        fits key =
          if T.length (B.runBuilder key) > maxImplicitKeyLength then Nothing else Just key

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

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

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

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