{-# LANGUAGE LinearTypes #-}
{-# OPTIONS_HADDOCK not-home #-}

-- | Building blocks of the YAML output.
--
-- This module is intended for internal use only, and may change without warning
-- in subsequent releases.
module Yamlet.Internal.Emit
  ( -- * Scalars
    plainSyntax
  , plainLines
  , singleQuoted
  , singleQuotedLines
  , quotedPlain
  , quotedPlainLines
  , doubleQuoted
  , doubleQuotedLines
  , literalBlock
  , foldedBlock
  , hasKeepIndicator
  , needsIndentIndicator

    -- * Other
  , indentStep
  , tagText
  , tagHandles
  , tagDirective
  , isPrintable
  , isScalarChar
  , spaces
  ) where

import Data.ByteString qualified as BS
import Data.Char
import Data.Containers.ListUtils
import Data.Maybe
import Data.Text qualified as T
import Data.Text.Builder.Linear qualified as B
import Data.Text.Builder.Linear.Buffer qualified as B
import Data.Text.Encoding qualified as T
import Data.Text.Internal qualified as T
import Numeric

import Yamlet.Internal.Chars
import Yamlet.Internal.Syntax
import Yamlet.Internal.Utils

-- | The number of spaces that the content of a block collection or a block
-- scalar is indented by, relative to its parent. The output style is fixed.
indentStep :: Int
indentStep :: Int
indentStep = Int
2

-- | The text reads back as the same text if it is a plain scalar on one line,
-- in a flow collection if the flag is set. The check ignores the schema, so
-- e.g. @12@ passes.
plainSyntax :: Bool -> T.Text -> Bool
plainSyntax :: Bool -> Text -> Bool
plainSyntax Bool
inFlow Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
  Maybe (Char, Text)
Nothing -> Bool
False
  Just (Char
c, Text
rest) ->
    Char -> Text -> Bool
firstOk Char
c Text
rest
      Bool -> Bool -> Bool
&& Char -> Bool
isPlainChar Char
c
      Bool -> Bool -> Bool
&& Char -> Text -> Bool
valid Char
c Text
rest
      Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Text -> Bool
textIsPrefixOf Text
"---" Text
t)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Text -> Bool
textIsPrefixOf Text
"..." Text
t)
  where
    -- The characters after the given one are valid in a plain scalar, and
    -- the text has no ": " or " #" and does not end with white space or a
    -- colon.
    valid :: Char -> T.Text -> Bool
    valid :: Char -> Text -> Bool
valid Char
prev Text
s = case Text -> Maybe (Char, Text)
T.uncons Text
s of
      Maybe (Char, Text)
Nothing -> Bool -> Bool
not ((Word8 -> Bool) -> Char -> Bool
asciiChar Word8 -> Bool
isWhite Char
prev) Bool -> Bool -> Bool
&& Char
prev Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':'
      Just (Char
c, Text
s')
        | Bool -> Bool
not (Char -> Bool
isPlainChar Char
c) -> Bool
False
        | Char
prev 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
' ' -> Bool
False
        | Char
prev 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
'#' -> Bool
False
        | Bool
otherwise -> Char -> Text -> Bool
valid Char
c Text
s'

    -- YAML 1.1 parsers end a plain scalar at a question mark in a flow
    -- collection, or reject it. As one top-level function with the flag for
    -- both callers, it made the encode benchmark of the text input allocate
    -- several times more.
    isPlainChar :: Char -> Bool
    isPlainChar :: Char -> Bool
isPlainChar Char
c =
      (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| (Char -> Bool
isScalarChar Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\t'))
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Bool
inFlow Bool -> Bool -> Bool
&& ((Word8 -> Bool) -> Char -> Bool
asciiChar Word8 -> Bool
isFlowIndicator Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?'))

    -- YAML 1.1 parsers reject a plain scalar that starts with a colon in a
    -- flow collection.
    firstOk :: Char -> T.Text -> Bool
    firstOk :: Char -> Text -> Bool
firstOk Char
c Text
rest
      | Bool
inFlow Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' = Bool
False
      | forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem @[] Char
c [Char]
"-?:" = case Text -> Maybe (Char, Text)
T.uncons Text
rest of
          Just (Char
c', Text
_) -> Bool -> Bool
not ((Word8 -> Bool) -> Char -> Bool
asciiChar Word8 -> Bool
isWhite Char
c')
          Maybe (Char, Text)
Nothing -> Bool
False
      | Bool
otherwise = Bool -> Bool
not ((Word8 -> Bool) -> Char -> Bool
asciiChar Word8 -> Bool
isWhite Char
c) Bool -> Bool -> Bool
&& Bool -> Bool
not ((Word8 -> Bool) -> Char -> Bool
asciiChar Word8 -> Bool
isIndicator Char
c)

-- | A plain scalar on the lines that start at the positions, with the lines
-- after the first one at the given indentation, if the text can be plain. It
-- is in a flow collection if the flag is set.
plainLines :: Bool -> Int -> [Int] -> T.Text -> Maybe B.Builder
plainLines :: Bool -> Int -> [Int] -> Text -> Maybe Builder
plainLines Bool
inFlow Int
indent [Int]
starts Text
t
  | Bool -> Text -> Bool
plainSyntax Bool
inFlow Text
first Bool -> Bool -> Bool
&& ((Maybe Int, Text) -> Bool) -> [(Maybe Int, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text -> Bool
plainNextLine (Text -> Bool)
-> ((Maybe Int, Text) -> Text) -> (Maybe Int, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Int, Text) -> Text
forall a b. (a, b) -> b
snd) [(Maybe Int, Text)]
rest =
      Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Int -> (Text -> Builder) -> (Text, [(Maybe Int, Text)]) -> Builder
onLines Int
indent Text -> Builder
B.fromText (Text, [(Maybe Int, Text)])
ls)
  | Bool
otherwise = Maybe Builder
forall a. Maybe a
Nothing
  where
    ls :: (Text, [(Maybe Int, Text)])
ls@(Text
first, [(Maybe Int, Text)]
rest) = Bool
-> Bool
-> (Char -> Bool)
-> [Int]
-> Text
-> (Text, [(Maybe Int, Text)])
flowLines Bool
False Bool
False ((Word8 -> Bool) -> Char -> Bool
asciiChar Word8 -> Bool
isWhite) [Int]
starts Text
t

    -- The text reads back as the same text on a line of a plain scalar after
    -- the first line. Such a line can start with an indicator, but not with a
    -- comment.
    plainNextLine :: T.Text -> Bool
    plainNextLine :: Text -> Bool
plainNextLine Text
l = case (Text -> Maybe (Char, Text)
T.uncons Text
l, Text -> Maybe (Text, Char)
T.unsnoc Text
l) of
      (Just (Char
c, Text
_), Just (Text
_, Char
lastChar)) ->
        Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#'
          Bool -> Bool -> Bool
&& Bool -> Bool
not ((Word8 -> Bool) -> Char -> Bool
asciiChar Word8 -> Bool
isWhite Char
c)
          Bool -> Bool -> Bool
&& Bool -> Bool
not ((Word8 -> Bool) -> Char -> Bool
asciiChar Word8 -> Bool
isWhite Char
lastChar)
          Bool -> Bool -> Bool
&& Char
lastChar Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':'
          Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isPlainChar Text
l
          Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Text -> Bool
T.isInfixOf Text
": " Text
l)
          Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Text -> Bool
T.isInfixOf Text
" #" Text
l)
      (Maybe (Char, Text), Maybe (Text, Char))
_ -> Bool
False

    -- As in 'plainSyntax'.
    isPlainChar :: Char -> Bool
    isPlainChar :: Char -> Bool
isPlainChar Char
c =
      (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| (Char -> Bool
isScalarChar Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\t'))
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Bool
inFlow Bool -> Bool -> Bool
&& ((Word8 -> Bool) -> Char -> Bool
asciiChar Word8 -> Bool
isFlowIndicator Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?'))

-- | A single-quoted scalar on one line, if the text has no line breaks.
singleQuoted :: T.Text -> Maybe B.Builder
singleQuoted :: Text -> Maybe Builder
singleQuoted Text
t
  | (Char -> Bool) -> Text -> Bool
T.all (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t' Bool -> Bool -> Bool
|| Char -> Bool
isScalarChar Char
c) Text
t =
      Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ Builder
"'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
B.fromText (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"'" Text
"''" Text
t) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"'"
  | Bool
otherwise = Maybe Builder
forall a. Maybe a
Nothing

-- | A single-quoted scalar on the lines that start at the positions, as in
-- 'plainLines', if single quotes can hold the text.
singleQuotedLines :: Int -> [Int] -> T.Text -> Maybe B.Builder
singleQuotedLines :: Int -> [Int] -> Text -> Maybe Builder
singleQuotedLines Int
indent [Int]
starts Text
t
  | [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
starts = Text -> Maybe Builder
singleQuoted Text
t
  | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Char -> Bool) -> Text -> Bool
T.all (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t' Bool -> Bool -> Bool
|| Char -> Bool
isScalarChar Char
c)) (Text
first Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Maybe Int, Text) -> Text) -> [(Maybe Int, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Int, Text) -> Text
forall a b. (a, b) -> b
snd [(Maybe Int, Text)]
rest) =
      Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ Builder
"'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> (Text -> Builder) -> (Text, [(Maybe Int, Text)]) -> Builder
onLines Int
indent (Text -> Builder
B.fromText (Text -> Builder) -> (Text -> Text) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"'" Text
"''") (Text, [(Maybe Int, Text)])
ls Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"'"
  | Bool
otherwise = Maybe Builder
forall a. Maybe a
Nothing
  where
    ls :: (Text, [(Maybe Int, Text)])
ls@(Text
first, [(Maybe Int, Text)]
rest) = Bool
-> Bool
-> (Char -> Bool)
-> [Int]
-> Text
-> (Text, [(Maybe Int, Text)])
flowLines Bool
True Bool
False ((Word8 -> Bool) -> Char -> Bool
asciiChar Word8 -> Bool
isWhite) [Int]
starts Text
t

-- | The quoted form of a plain scalar whose text cannot be plain: in single
-- quotes, or in double quotes if the text has a tab or a character that
-- single quotes cannot hold. A tab in single quotes is not visible.
quotedPlain :: T.Text -> B.Builder
quotedPlain :: Text -> Builder
quotedPlain = Int -> [Int] -> Text -> Builder
quotedPlainLines Int
0 []

-- | 'quotedPlain' on the lines that start at the positions, as in
-- 'plainLines'.
quotedPlainLines :: Int -> [Int] -> T.Text -> B.Builder
quotedPlainLines :: Int -> [Int] -> Text -> Builder
quotedPlainLines Int
indent [Int]
starts Text
t
  | (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t') Text
t = Int -> [Int] -> Text -> Builder
doubleQuotedLines Int
indent [Int]
starts Text
t
  | Bool
otherwise =
      Builder -> Maybe Builder -> Builder
forall a. a -> Maybe a -> a
fromMaybe (Int -> [Int] -> Text -> Builder
doubleQuotedLines Int
indent [Int]
starts Text
t) (Int -> [Int] -> Text -> Maybe Builder
singleQuotedLines Int
indent [Int]
starts Text
t)

-- | A double-quoted scalar with escapes for the characters that need them.
doubleQuoted :: T.Text -> B.Builder
doubleQuoted :: Text -> Builder
doubleQuoted Text
t = Builder
"\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
doubleQuotedText Text
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\""

-- | A double-quoted scalar on the lines that start at the positions, as in
-- 'plainLines'. The escapes of the tabs keep them at the ends of the lines.
doubleQuotedLines :: Int -> [Int] -> T.Text -> B.Builder
doubleQuotedLines :: Int -> [Int] -> Text -> Builder
doubleQuotedLines Int
indent [Int]
starts Text
t
  | [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
starts = Text -> Builder
doubleQuoted Text
t
  | Bool
otherwise =
      Builder
"\""
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> (Text -> Builder) -> (Text, [(Maybe Int, Text)]) -> Builder
onLines Int
indent Text -> Builder
doubleQuotedText (Bool
-> Bool
-> (Char -> Bool)
-> [Int]
-> Text
-> (Text, [(Maybe Int, Text)])
flowLines Bool
True Bool
True (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') [Int]
starts Text
t)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\""

-- | The text of a double-quoted scalar, with escapes for the characters that
-- need them.
doubleQuotedText :: T.Text -> B.Builder
-- The loop writes to the buffer, and copies each run of characters without
-- escapes at once. A fold of builders over the characters allocates a
-- closure for each character since text 2.1.4, whose 'T.foldr' no longer
-- fuses, and the encode benchmark of the config input allocated more. A
-- fold of builders over the runs allocated more in the render benchmark of
-- the JSON input.
doubleQuotedText :: Text -> Builder
doubleQuotedText = (Buffer %1 -> Buffer) -> Builder
B.Builder ((Buffer %1 -> Buffer) -> Builder)
-> (Text -> Buffer %1 -> Buffer) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Buffer %1 -> Buffer
go
  where
    go :: T.Text -> B.Buffer %1 -> B.Buffer
    go :: Text -> Buffer %1 -> Buffer
go Text
t Buffer
b = case (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
needsEscape Text
t of
      (Text
run, Text
rest) -> case Text -> Maybe (Char, Text)
T.uncons Text
rest of
        Just (Char
c, Text
rest') -> Text -> Buffer %1 -> Buffer
go Text
rest' (Buffer %1 -> Char -> Buffer
escape (Buffer
b Buffer %1 -> Text -> Buffer
B.|> Text
run) Char
c)
        Maybe (Char, Text)
Nothing -> Buffer
b Buffer %1 -> Text -> Buffer
B.|> Text
run

    needsEscape :: Char -> Bool
    needsEscape :: Char -> Bool
needsEscape Char
c = 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
'\\' Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isScalarChar Char
c)

    escape :: B.Buffer %1 -> Char -> B.Buffer
    escape :: Buffer %1 -> Char -> Buffer
escape Buffer
b = \case
      Char
'"' -> Buffer
b Buffer %1 -> Text -> Buffer
B.|> Text
"\\\""
      Char
'\\' -> Buffer
b Buffer %1 -> Text -> Buffer
B.|> Text
"\\\\"
      Char
'\n' -> Buffer
b Buffer %1 -> Text -> Buffer
B.|> Text
"\\n"
      Char
'\t' -> Buffer
b Buffer %1 -> Text -> Buffer
B.|> Text
"\\t"
      Char
'\r' -> Buffer
b Buffer %1 -> Text -> Buffer
B.|> Text
"\\r"
      Char
'\0' -> Buffer
b Buffer %1 -> Text -> Buffer
B.|> Text
"\\0"
      Char
c
        | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
xEscapeDigits -> Buffer
b Buffer %1 -> Text -> Buffer
B.|> Text
"\\x" Buffer %1 -> Text -> Buffer
B.|> Int -> Int -> Text
hex Int
xEscapeDigits (Char -> Int
ord Char
c)
        | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
uEscapeDigits -> Buffer
b Buffer %1 -> Text -> Buffer
B.|> Text
"\\u" Buffer %1 -> Text -> Buffer
B.|> Int -> Int -> Text
hex Int
uEscapeDigits (Char -> Int
ord Char
c)
        | Bool
otherwise -> Buffer
b Buffer %1 -> Text -> Buffer
B.|> Text
"\\U" Buffer %1 -> Text -> Buffer
B.|> Int -> Int -> Text
hex Int
bigUEscapeDigits (Char -> Int
ord Char
c)

    hex :: Int -> Int -> T.Text
    hex :: Int -> Int -> Text
hex Int
k Int
i = [Char] -> Text
T.pack (Int -> Int -> [Char]
upperHex Int
k Int
i)

-- | The lines of a flow scalar that start at the positions: the first line,
-- and each next line with the number of empty lines above it, or 'Nothing'
-- after an escaped line break. A line break replaces a space of the text,
-- and an empty line replaces a line break of the text. A position where the
-- style cannot start a line and keep the text joins its two lines.
--
-- The first flag allows an empty first and last line, e.g. for a quoted
-- scalar. The second flag allows escaped line breaks. The parser drops a
-- white character at the start or the end of a line.
flowLines
  :: Bool -> Bool -> (Char -> Bool) -> [Int] -> T.Text -> (T.Text, [(Maybe Int, T.Text)])
flowLines :: Bool
-> Bool
-> (Char -> Bool)
-> [Int]
-> Text
-> (Text, [(Maybe Int, Text)])
flowLines Bool
quoted Bool
escapes Char -> Bool
white [Int]
starts Text
t = case [Int] -> Text -> [Text]
splitLines [Int]
starts Text
t of
  Text
first : [Text]
rest -> Bool -> Text -> [Text] -> (Text, [(Maybe Int, Text)])
go Bool
True Text
first [Text]
rest
  [] -> (Text
t, [])
  where
    go :: Bool -> T.Text -> [T.Text] -> (T.Text, [(Maybe Int, T.Text)])
    go :: Bool -> Text -> [Text] -> (Text, [(Maybe Int, Text)])
go Bool
isFirst Text
a = \case
      [] -> (Text
a, [])
      Text
b : [Text]
rest -> case Bool -> Bool -> Text -> Text -> Maybe (Text, Maybe Int)
lineEnd Bool
isFirst ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rest) Text
a Text
b of
        Just (Text
a', Maybe Int
end) -> let (Text
l, [(Maybe Int, Text)]
ls) = Bool -> Text -> [Text] -> (Text, [(Maybe Int, Text)])
go Bool
False Text
b [Text]
rest in (Text
a', (Maybe Int
end, Text
l) (Maybe Int, Text) -> [(Maybe Int, Text)] -> [(Maybe Int, Text)]
forall a. a -> [a] -> [a]
: [(Maybe Int, Text)]
ls)
        Maybe (Text, Maybe Int)
Nothing -> Bool -> Text -> [Text] -> (Text, [(Maybe Int, Text)])
go Bool
isFirst (Text -> Text -> Text
join Text
a Text
b) [Text]
rest

    -- The pieces of 'splitLines' follow each other in the array of the text,
    -- so two of them join without a copy. A copy at each join would make the
    -- time quadratic in the number of lines.
    join :: T.Text -> T.Text -> T.Text
    join :: Text -> Text -> Text
join (T.Text Array
arr Int
off Int
len) b :: Text
b@(T.Text Array
_ Int
_ Int
len')
      | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Text
b
      | Bool
otherwise = Array -> Int -> Int -> Text
T.Text Array
arr Int
off (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len')

    -- The first line without the text that the line break replaces, and the
    -- number of empty lines.
    lineEnd :: Bool -> Bool -> T.Text -> T.Text -> Maybe (T.Text, Maybe Int)
    lineEnd :: Bool -> Bool -> Text -> Text -> Maybe (Text, Maybe Int)
lineEnd Bool
isFirst Bool
isLast Text
a Text
b
      | Bool -> Bool
not Bool
startOk = Maybe (Text, Maybe Int)
forall a. Maybe a
Nothing
      | Just (Text
a', Char
' ') <- Text -> Maybe (Text, Char)
T.unsnoc Text
a, Text -> Bool
endOk Text
a' = (Text, Maybe Int) -> Maybe (Text, Maybe Int)
forall a. a -> Maybe a
Just (Text
a', Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)
      | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0, Text -> Bool
endOk Text
a'' = (Text, Maybe Int) -> Maybe (Text, Maybe Int)
forall a. a -> Maybe a
Just (Text
a'', Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k)
      | Bool
escapes = (Text, Maybe Int) -> Maybe (Text, Maybe Int)
forall a. a -> Maybe a
Just (Text
a, Maybe Int
forall a. Maybe a
Nothing)
      | Bool
otherwise = Maybe (Text, Maybe Int)
forall a. Maybe a
Nothing
      where
        startOk :: Bool
        startOk :: Bool
startOk = case Text -> Maybe (Char, Text)
T.uncons Text
b of
          Just (Char
c, Text
_) -> Bool -> Bool
not (Char -> Bool
white Char
c)
          Maybe (Char, Text)
Nothing -> Bool
quoted Bool -> Bool -> Bool
&& Bool
isLast

        endOk :: T.Text -> Bool
        endOk :: Text -> Bool
endOk Text
x = case Text -> Maybe (Text, Char)
T.unsnoc Text
x of
          Just (Text
_, Char
c) -> Bool -> Bool
not (Char -> Bool
white Char
c)
          Maybe (Text, Char)
Nothing -> Bool
quoted Bool -> Bool -> Bool
&& Bool
isFirst

        k :: Int
        k :: Int
k = Text -> Int
T.length ((Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
a)

        a'' :: T.Text
        a'' :: Text
a'' = Int -> Text -> Text
T.dropEnd Int
k Text
a

-- | The flow scalar on its lines, with each line after the first one at the
-- given indentation.
onLines :: Int -> (T.Text -> B.Builder) -> (T.Text, [(Maybe Int, T.Text)]) -> B.Builder
onLines :: Int -> (Text -> Builder) -> (Text, [(Maybe Int, Text)]) -> Builder
onLines Int
indent Text -> Builder
text (Text
first, [(Maybe Int, Text)]
rest) =
  Text -> Builder
text Text
first Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Maybe Int -> Builder
lineBreak Maybe Int
end 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
<> Text -> Builder
text Text
l | (Maybe Int
end, Text
l) <- [(Maybe Int, Text)]
rest]
  where
    lineBreak :: Maybe Int -> B.Builder
    lineBreak :: Maybe Int -> Builder
lineBreak = \case
      Just Int
k -> Text -> Builder
B.fromText (Int -> Text -> Text
T.replicate (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"\n")
      Maybe Int
Nothing -> Builder
"\\\n"

-- | The text split at the positions. A position that does not come after the
-- one before it is ignored, and a position after the end of the text ends
-- the split.
splitLines :: [Int] -> T.Text -> [T.Text]
splitLines :: [Int] -> Text -> [Text]
splitLines = Int -> [Int] -> Text -> [Text]
go Int
0
  where
    go :: Int -> [Int] -> T.Text -> [T.Text]
    go :: Int -> [Int] -> Text -> [Text]
go Int
at [Int]
starts Text
s = case [Int]
starts of
      Int
p : [Int]
rest
        | Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
at -> Int -> [Int] -> Text -> [Text]
go Int
at [Int]
rest Text
s
        | Text -> Int -> Ordering
T.compareLength Text
s (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
at) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT -> [Text
s]
        | Bool
otherwise -> let (Text
a, Text
b) = Int -> Text -> (Text, Text)
T.splitAt (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
at) Text
s in Text
a Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Int -> [Int] -> Text -> [Text]
go Int
p [Int]
rest Text
b
      [] -> [Text
s]

-- | The header and the content lines of a literal block scalar, with the
-- content at the given indentation.
literalBlock :: Int -> T.Text -> Maybe (B.Builder, B.Builder)
literalBlock :: Int -> Text -> Maybe (Builder, Builder)
literalBlock Int
indent Text
t = do
  (header, body, trailing) <- Bool -> Text -> Maybe (Builder, Text, Int)
blockParts Bool
True Text
t
  let content
        -- The line break of the header comes first, and each empty line
        -- below it is one line break of the text.
        | Text -> Bool
T.null Text
body = Text -> Builder
B.fromText (Int -> Text -> Text
T.replicate Int
trailing Text
"\n")
        | Bool
otherwise =
            [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((Text -> Builder) -> [Text] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Builder
line Int
indent) (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"\n" Text
body))
              Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
B.fromText (Int -> Text -> Text
T.replicate (Int
trailing Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
"\n")
  Just ("|" <> header, content)

-- | The header and the content lines of a folded block scalar, with the
-- content at the given indentation. It has no keep indicator. Each line of
-- the text becomes one line of the output, or several lines if the lines
-- start at the positions.
foldedBlock :: Int -> [Int] -> T.Text -> Maybe (B.Builder, B.Builder)
foldedBlock :: Int -> [Int] -> Text -> Maybe (Builder, Builder)
foldedBlock Int
indent [Int]
starts Text
t = do
  (header, body, _) <- Bool -> Text -> Maybe (Builder, Text, Int)
blockParts Bool
False Text
t
  let (leading, rest) = span T.null (if T.null body then [] else T.splitOn "\n" body)
      content =
        [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
leading) Builder
"\n")
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> Int -> [Int] -> [(Int, Text)] -> Builder
go Maybe Text
forall a. Maybe a
Nothing ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
leading) [Int]
starts ([Text] -> [(Int, Text)]
groups [Text]
rest)
  Just (">" <> header, content)
  where
    -- The lines with content, each with the number of empty lines before it.
    groups :: [T.Text] -> [(Int, T.Text)]
    groups :: [Text] -> [(Int, Text)]
groups [Text]
ls = case (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Text -> Bool
T.null [Text]
ls of
      ([Text]
_, []) -> []
      ([Text]
empties, Text
l : [Text]
ls') -> ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
empties, Text
l) (Int, Text) -> [(Int, Text)] -> [(Int, Text)]
forall a. a -> [a] -> [a]
: [Text] -> [(Int, Text)]
groups [Text]
ls'

    -- A line break between two lines that start with content folds into a
    -- space, so the output needs one empty line more there. The group starts
    -- at the offset.
    go :: Maybe T.Text -> Int -> [Int] -> [(Int, T.Text)] -> B.Builder
    go :: Maybe Text -> Int -> [Int] -> [(Int, Text)] -> Builder
go Maybe Text
prev Int
offset [Int]
ss = \case
      [] -> Builder
forall a. Monoid a => a
mempty
      (Int
empties, Text
l) : [(Int, Text)]
ls ->
        let extra :: Int
extra = case Maybe Text
prev of
              Just Text
p | Bool -> Bool
not (Text -> Bool
isSpaced Text
p) Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
isSpaced Text
l) -> Int
1
              Maybe Text
_ -> Int
0
            separator :: Builder
separator = case Maybe Text
prev of
              Just Text
_ -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate (Int
empties Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
extra) Builder
"\n")
              Maybe Text
Nothing -> Builder
forall a. Monoid a => a
mempty
            lineStart :: Int
lineStart = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
empties
            lineEnd :: Int
lineEnd = Int
lineStart Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
l
            ([Int]
inLine, [Int]
ss') = (Int -> Bool) -> [Int] -> ([Int], [Int])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lineEnd) ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lineStart) [Int]
ss)
        in Builder
separator
             Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
               ((Text -> Builder) -> [Text] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Builder
line Int
indent) ([Int] -> Text -> [Text]
lineParts ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
lineStart) [Int]
inLine) Text
l))
             Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> Int -> [Int] -> [(Int, Text)] -> Builder
go (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
l) (Int
lineEnd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int]
ss' [(Int, Text)]
ls

    -- The parts of a line of the text that start at the positions. A line
    -- break replaces a space between two parts that start with content.
    lineParts :: [Int] -> T.Text -> [T.Text]
    lineParts :: [Int] -> Text -> [Text]
lineParts [Int]
ps Text
l
      | [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
ps Bool -> Bool -> Bool
|| Text -> Bool
isSpaced Text
l = [Text
l]
      | Bool
otherwise = [Text] -> [Text]
join ([Int] -> Text -> [Text]
splitLines [Int]
ps Text
l)
      where
        join :: [T.Text] -> [T.Text]
        join :: [Text] -> [Text]
join = \case
          Text
a : Text
b : [Text]
rest
            | Just (Text
a', Char
' ') <- Text -> Maybe (Text, Char)
T.unsnoc Text
a
            , Just (Char
c, Text
_) <- Text -> Maybe (Char, Text)
T.uncons Text
b
            , 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
'\t' ->
                Text
a' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
join (Text
b Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rest)
            | Bool
otherwise -> [Text] -> [Text]
join (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
rest)
          [Text]
parts -> [Text]
parts

    isSpaced :: T.Text -> Bool
    isSpaced :: Text -> Bool
isSpaced Text
l = case Text -> Maybe (Char, Text)
T.uncons Text
l of
      Just (Char
c, Text
_) -> 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
'\t'
      Maybe (Char, Text)
Nothing -> Bool
False

-- | A block scalar with the text has the keep indicator, so the empty lines at
-- its end are its content. Without content, the clip indicator drops the
-- line breaks too.
hasKeepIndicator :: T.Text -> Bool
hasKeepIndicator :: Text -> Bool
hasKeepIndicator Text
t = Int
trailing Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| Text -> Bool
T.null Text
body Bool -> Bool -> Bool
&& Int
trailing Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  where
    body :: T.Text
    body :: Text
body = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
t

    trailing :: Int
    trailing :: Int
trailing = Text -> Int
T.length Text
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
body

-- | The header of a block scalar, its content without the trailing line breaks
-- and the number of these line breaks. The flag allows the keep indicator for
-- trailing empty lines.
blockParts :: Bool -> T.Text -> Maybe (B.Builder, T.Text, Int)
blockParts :: Bool -> Text -> Maybe (Builder, Text, Int)
blockParts Bool
allowKeep Text
t
  | Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.all (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t' Bool -> Bool -> Bool
|| Char -> Bool
isScalarChar Char
c) Text
t) = Maybe (Builder, Text, Int)
forall a. Maybe a
Nothing
  | Bool
keep Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
allowKeep = Maybe (Builder, Text, Int)
forall a. Maybe a
Nothing
  | Bool
otherwise = (Builder, Text, Int) -> Maybe (Builder, Text, Int)
forall a. a -> Maybe a
Just (Builder
indicator Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
chomping, Text
body, Int
trailing)
  where
    keep :: Bool
    keep :: Bool
keep = Text -> Bool
hasKeepIndicator Text
t

    body :: T.Text
    body :: Text
body = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
t

    trailing :: Int
    trailing :: Int
trailing = Text -> Int
T.length Text
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
body

    indicator :: B.Builder
    indicator :: Builder
indicator = if Text -> Bool
needsIndentIndicator Text
t then Int -> Builder
forall a. (Integral a, FiniteBits a) => a -> Builder
B.fromDec Int
indentStep else Builder
forall a. Monoid a => a
mempty

    chomping :: B.Builder
    chomping :: Builder
chomping
      | Int
trailing Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Builder
"-"
      | Bool
keep = Builder
"+"
      | Bool
otherwise = Builder
forall a. Monoid a => a
mempty

-- | A block scalar with the text needs an indentation indicator, because its
-- first line with content starts with a space or a tab. YAML 1.2 does not
-- need the indicator for a tab, but libyaml rejects the block scalar without
-- it. Parsers do not agree on the meaning of the indicator at the top level,
-- so a caller there writes such a text with quotes.
needsIndentIndicator :: T.Text -> Bool
needsIndentIndicator :: Text -> Bool
needsIndentIndicator Text
t = case Text -> Maybe (Char, Text)
T.uncons ((Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
t) of
  Just (Char
c, Text
_) -> 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
'\t'
  Maybe (Char, Text)
Nothing -> Bool
False

-- | A line of a block scalar. An empty line gets no indentation.
line :: Int -> T.Text -> B.Builder
line :: Int -> Text -> Builder
line Int
indent Text
l
  | Text -> Bool
T.null Text
l = Builder
"\n"
  | Bool
otherwise = Builder
"\n" 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
<> Text -> Builder
B.fromText Text
l

-- | A tag in the shortest form that reads back as the same tag. A tag that no
-- text can hold, e.g. an empty tag, becomes the non-specific tag @!@.
--
-- A global tag that is not a valid URI needs the directive of
-- 'tagDirective' in its document.
tagText :: T.Text -> B.Builder
tagText :: Text -> Builder
tagText Text
tag
  | Text -> Bool
T.null Text
tag = Builder
"!"
  | Just Text
suffix <- Text -> Text -> Maybe Text
textStripPrefix Text
coreTagPrefix Text
tag
  , Bool -> Bool
not (Text -> Bool
T.null Text
suffix) =
      Builder
"!!" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
shorthand Text
suffix
  | Just Text
suffix <- Text -> Text -> Maybe Text
textStripPrefix Text
"!" Text
tag
  , Bool -> Bool
not (Text -> Bool
T.null Text
suffix) =
      Builder
"!" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
shorthand Text
suffix
  | Just (Char
c, Text
suffix) <- Text -> Maybe (Char, Text)
T.uncons Text
tag
  , Bool -> Bool
not (Text -> Bool
isVerbatim Text
tag) =
      if Text -> Bool
T.null Text
suffix then Builder
"!" else Char -> Builder
handleText Char
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
shorthand Text
suffix
  | Bool
otherwise = Builder
"!<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
B.fromText Text
tag Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
">"
  where
    -- The text of a tag suffix. A character that the form does not allow gets
    -- a %XX escape, which the parser decodes. So does #, which YAML allows,
    -- but libyaml, PyYAML and go-yaml reject.
    shorthand :: T.Text -> B.Builder
    shorthand :: Text -> Builder
shorthand =
      (Char -> Builder -> Builder) -> Builder -> Text -> Builder
forall a. (Char -> a -> a) -> a -> Text -> a
T.foldr
        ( \Char
x Builder
b ->
            (if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#' Bool -> Bool -> Bool
&& (Word8 -> Bool) -> Char -> Bool
asciiChar Word8 -> Bool
isTagChar Char
x then Char -> Builder
B.fromChar Char
x else Char -> Builder
percentEscape Char
x)
              Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b
        )
        Builder
forall a. Monoid a => a
mempty

-- | The handles for the tags of the node and the nodes in it that are not
-- valid URIs, each once.
tagHandles :: Node -> [Char]
tagHandles :: Node -> [Char]
tagHandles Node
n0 = [Char] -> [Char]
forall a. Ord a => [a] -> [a]
nubOrd (Node -> [Char] -> [Char]
go Node
n0 [])
  where
    go :: Node -> [Char] -> [Char]
    go :: Node -> [Char] -> [Char]
go Node
n [Char]
acc =
      (case Node
n.props.tag of Tag Text
t -> ([Char] -> [Char])
-> (Char -> [Char] -> [Char]) -> Maybe Char -> [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char] -> [Char]
forall a. a -> a
id (:) (Text -> Maybe Char
tagHandle Text
t); Tag
_ -> [Char] -> [Char]
forall a. a -> a
id) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
        case Node
n.content of
          SequenceContent CollectionStyle
_ [Node]
xs -> (Node -> [Char] -> [Char]) -> [Char] -> [Node] -> [Char]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Node -> [Char] -> [Char]
go [Char]
acc [Node]
xs
          MappingContent CollectionStyle
_ [(Node, Node)]
kvs -> ((Node, Node) -> [Char] -> [Char])
-> [Char] -> [(Node, Node)] -> [Char]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Node
k, Node
v) -> Node -> [Char] -> [Char]
go Node
k ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Char] -> [Char]
go Node
v) [Char]
acc [(Node, Node)]
kvs
          Content
_ -> [Char]
acc

    -- The character whose handle a tag needs, if the tag needs a directive.
    tagHandle :: T.Text -> Maybe Char
    tagHandle :: Text -> Maybe Char
tagHandle Text
tag = case Text -> Maybe (Char, Text)
T.uncons Text
tag of
      Just (Char
c, Text
suffix)
        | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'!'
        , Bool -> Bool
not (Text -> Bool
T.null Text
suffix)
        , Bool -> Bool
not (Text -> Text -> Bool
textIsPrefixOf Text
coreTagPrefix Text
tag)
        , Bool -> Bool
not (Text -> Bool
isVerbatim Text
tag) ->
            Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c
      Maybe (Char, Text)
_ -> Maybe Char
forall a. Maybe a
Nothing

-- | The @%TAG@ directive of the handle for the tags that start with the
-- character, with the line break. The prefix is always an escape, because
-- e.g. a @#@ after a space starts a comment.
tagDirective :: Char -> B.Builder
tagDirective :: Char -> Builder
tagDirective Char
c = Builder
"%TAG " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
handleText Char
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
percentEscape Char
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"

handleText :: Char -> B.Builder
handleText :: Char -> Builder
handleText Char
c = Builder
"!t" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
B.fromText ([Char] -> Text
T.pack (Int -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
showHex (Char -> Int
ord Char
c) [Char]
"")) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"!"

-- | A global tag that a verbatim tag holds as it is. A % in a verbatim tag
-- starts an escape, and libyaml, PyYAML and go-yaml reject a #, so a tag with
-- a % or a # goes in a shorthand tag, with escapes.
isVerbatim :: T.Text -> Bool
isVerbatim :: Text -> Bool
isVerbatim Text
tag =
  Bool
hasScheme Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (\Char
c -> 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
'#' Bool -> Bool -> Bool
&& (Word8 -> Bool) -> Char -> Bool
asciiChar Word8 -> Bool
isUriChar Char
c) Text
tag
  where
    hasScheme :: Bool
    hasScheme :: Bool
hasScheme = case (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
tag of
      (Text
scheme, Text
rest) -> case Text -> Maybe (Char, Text)
T.uncons Text
scheme of
        Just (Char
c, Text
cs) ->
          Char -> Bool
isAscii Char
c
            Bool -> Bool -> Bool
&& Char -> Bool
isAlpha Char
c
            Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (\Char
x -> Char -> Bool
isAscii Char
x Bool -> Bool -> Bool
&& (Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem @[] Char
x [Char]
"+-.")) Text
cs
            Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
T.null Text
rest)
        Maybe (Char, Text)
Nothing -> Bool
False

-- | The %XX escapes of the UTF-8 bytes of a character.
percentEscape :: Char -> B.Builder
percentEscape :: Char -> Builder
percentEscape Char
c =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ Text -> Builder
B.fromText ([Char] -> Text
T.pack (Char
'%' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> Int -> [Char]
upperHex Int
percentDigits (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w)))
    | Word8
w <- ByteString -> [Word8]
BS.unpack (Text -> ByteString
T.encodeUtf8 (Char -> Text
T.singleton Char
c))
    ]

-- | The number in uppercase hex digits, with zeros in front up to the given
-- number of digits.
upperHex :: Int -> Int -> String
upperHex :: Int -> Int -> [Char]
upperHex Int
k Int
i = let s :: [Char]
s = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (Int -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
showHex Int
i [Char]
"") in Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) Char
'0' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

-- | c-printable without the line breaks and the byte order mark.
isPrintable :: Char -> Bool
isPrintable :: Char -> Bool
isPrintable Char
c
  | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
' ' = Bool
False
  | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'~' = Bool
True
  | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\xA0' = Bool
False
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\xFEFF' = Bool
False
  | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xD800' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xDFFF' = Bool
False
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\xFFFE' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\xFFFF' = Bool
False
  | Bool
otherwise = Bool
True

-- | A printable character that needs no escape in a scalar. YAML 1.1 reads
-- U+2028 and U+2029 as line breaks, so they get escapes too.
isScalarChar :: Char -> Bool
-- The guards for ASCII come first. Without them, the encode benchmark of
-- the long texts is slower.
isScalarChar :: Char -> Bool
isScalarChar Char
c
  | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
' ' = Bool
False
  | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'~' = Bool
True
  | Bool
otherwise = Char -> Bool
isPrintable Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\x2028' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\x2029'

spaces :: Int -> B.Builder
spaces :: Int -> Builder
spaces Int
k = Text -> Builder
B.fromText (Int -> Text -> Text
T.replicate Int
k Text
" ")