{-|
This library exposes functions for encoding any Aeson value as YAML.
There is also support for encoding multiple values into YAML
"documents".

This library is pure Haskell, and does not depend on C FFI with
libyaml. It is also licensed under the BSD3 license.

This module is meant to be imported qualified.
-}
{-# LANGUAGE OverloadedStrings #-}

module Data.Aeson.Yaml
  ( encode
  , encodeDocuments
  , encodeQuoted
  , encodeQuotedDocuments
  ) where

import Data.Aeson hiding (encode)
import qualified Data.Aeson
import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as ByteString.Builder
import qualified Data.ByteString.Lazy as ByteString.Lazy
import qualified Data.ByteString.Short as ByteString.Short
import Data.Char (isAlpha, isDigit)
import qualified Data.HashMap.Strict as HashMap
import Data.List (intersperse, sortOn)
import Data.Monoid ((<>), mconcat, mempty)
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.Text.Encoding as Text.Encoding
import qualified Data.Vector as Vector

b :: ByteString -> Builder
b :: ByteString -> Builder
b = ByteString -> Builder
ByteString.Builder.byteString

bl :: ByteString.Lazy.ByteString -> Builder
bl :: ByteString -> Builder
bl = ByteString -> Builder
ByteString.Builder.lazyByteString

bs :: ByteString.Short.ShortByteString -> Builder
bs :: ShortByteString -> Builder
bs = ShortByteString -> Builder
ByteString.Builder.shortByteString

indent :: Int -> Builder
indent :: Int -> Builder
indent 0 = Builder
forall a. Monoid a => a
mempty
indent n :: Int
n = ShortByteString -> Builder
bs "  " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Int -> Builder
indent (Int -> Builder) -> Int -> Builder
forall a b. (a -> b) -> a -> b
$! Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)

-- | Encode a value as YAML (lazy bytestring).
encode :: ToJSON a => a -> ByteString.Lazy.ByteString
encode :: a -> ByteString
encode v :: a
v =
  Builder -> ByteString
ByteString.Builder.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
  Bool -> Bool -> Int -> Value -> Builder
encodeBuilder Bool
False Bool
False 0 (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
v) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ShortByteString -> Builder
bs "\n"

-- | Encode multiple values separated by '\n---\n'. To encode values of different
-- types, @import Data.Aeson(ToJSON(toJSON))@ and do
-- @encodeDocuments [toJSON x, toJSON y, toJSON z]@.
encodeDocuments :: ToJSON a => [a] -> ByteString.Lazy.ByteString
encodeDocuments :: [a] -> ByteString
encodeDocuments vs :: [a]
vs = Builder -> ByteString
ByteString.Builder.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder
output Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ShortByteString -> Builder
bs "\n"
  where
    output :: Builder
output =
      [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$
      Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (ShortByteString -> Builder
bs "\n---\n") ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ (a -> Builder) -> [a] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool -> Int -> Value -> Builder
encodeBuilder Bool
False Bool
False 0 (Value -> Builder) -> (a -> Value) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON) [a]
vs

-- | Encode a value as YAML (lazy bytestring). Keys and strings are always
-- quoted.
encodeQuoted :: ToJSON a => a -> ByteString.Lazy.ByteString
encodeQuoted :: a -> ByteString
encodeQuoted v :: a
v =
  Builder -> ByteString
ByteString.Builder.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
  Bool -> Bool -> Int -> Value -> Builder
encodeBuilder Bool
True Bool
False 0 (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
v) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ShortByteString -> Builder
bs "\n"

-- | Encode multiple values separated by '\n---\n'. Keys and strings are always
-- quoted.
encodeQuotedDocuments :: ToJSON a => [a] -> ByteString.Lazy.ByteString
encodeQuotedDocuments :: [a] -> ByteString
encodeQuotedDocuments vs :: [a]
vs =
  Builder -> ByteString
ByteString.Builder.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder
output Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ShortByteString -> Builder
bs "\n"
  where
    output :: Builder
output =
      [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$
      Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (ShortByteString -> Builder
bs "\n---\n") ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ (a -> Builder) -> [a] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool -> Int -> Value -> Builder
encodeBuilder Bool
True Bool
False 0 (Value -> Builder) -> (a -> Value) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON) [a]
vs

encodeBuilder :: Bool -> Bool -> Int -> Data.Aeson.Value -> Builder
encodeBuilder :: Bool -> Bool -> Int -> Value -> Builder
encodeBuilder alwaysQuote :: Bool
alwaysQuote newlineBeforeObject :: Bool
newlineBeforeObject level :: Int
level value :: Value
value =
  case Value
value of
    Object hm :: Object
hm
      | Object -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Object
hm -> ShortByteString -> Builder
bs "{}"
      | Bool
otherwise ->
        [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$
        (if Bool
newlineBeforeObject
           then (Builder
prefix Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
:)
           else [Builder] -> [Builder]
forall a. a -> a
id) ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$
        Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
prefix ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$
        ((Text, Value) -> Builder) -> [(Text, Value)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> (Text, Value) -> Builder
keyValue Int
level) (((Text, Value) -> Text) -> [(Text, Value)] -> [(Text, Value)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Text, Value) -> Text
forall a b. (a, b) -> a
fst ([(Text, Value)] -> [(Text, Value)])
-> [(Text, Value)] -> [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList Object
hm)
      where prefix :: Builder
prefix = ShortByteString -> Builder
bs "\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
indent Int
level
    Array vec :: Array
vec
      | Array -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Array
vec -> ShortByteString -> Builder
bs "[]"
      | Bool
otherwise ->
        [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$
        (Builder
prefix Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
:) ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$
        Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
prefix ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$
        (Value -> Builder) -> [Value] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool -> Int -> Value -> Builder
encodeBuilder Bool
alwaysQuote Bool
False (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)) (Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
vec)
      where prefix :: Builder
prefix = ShortByteString -> Builder
bs "\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
indent Int
level Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ShortByteString -> Builder
bs "- "
    String s :: Text
s -> Bool -> Bool -> Int -> Text -> Builder
encodeText Bool
True Bool
alwaysQuote Int
level Text
s
    Number n :: Scientific
n -> ByteString -> Builder
bl (Scientific -> ByteString
forall a. ToJSON a => a -> ByteString
Data.Aeson.encode Scientific
n)
    Bool bool :: Bool
bool -> ByteString -> Builder
bl (Bool -> ByteString
forall a. ToJSON a => a -> ByteString
Data.Aeson.encode Bool
bool)
    Null -> ShortByteString -> Builder
bs "null"
  where
    keyValue :: Int -> (Text, Value) -> Builder
keyValue level' :: Int
level' (k :: Text
k, v :: Value
v) =
      [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ Bool -> Bool -> Int -> Text -> Builder
encodeText Bool
False Bool
alwaysQuote Int
level Text
k
        , ":"
        , case Value
v of
            Object hm :: Object
hm
              | Bool -> Bool
not (Object -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Object
hm) -> ""
            Array vec :: Array
vec
              | Bool -> Bool
not (Array -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Array
vec) -> ""
            _ -> " "
        , Bool -> Bool -> Int -> Value -> Builder
encodeBuilder Bool
alwaysQuote Bool
True (Int
level' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Value
v
        ]

encodeText :: Bool -> Bool -> Int -> Text -> Builder
encodeText :: Bool -> Bool -> Int -> Text -> Builder
encodeText canMultiline :: Bool
canMultiline alwaysQuote :: Bool
alwaysQuote level :: Int
level s :: Text
s
  -- s is a value, not a map key, and contains newlines; can be inserted
  -- literally with `|` syntax
  | Bool
canMultiline Bool -> Bool -> Bool
&& "\n" Text -> Text -> Bool
`Text.isSuffixOf` Text
s = Int -> [Text] -> Builder
encodeLines Int
level (Text -> [Text]
Text.lines Text
s)
  -- s is a number, date, or boolString; single-quote
  | (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
isNumberOrDateRelated Text
s Bool -> Bool -> Bool
|| Bool
isBoolString = Builder
singleQuote
  -- s should be quoted, AND s is not unsafe; single-quote
  | Bool
alwaysQuote Bool -> Bool -> Bool
&& Bool
unquotable = Builder
singleQuote
  -- s should be quoted, OR s might be unsafe; double-quote
  | Bool
alwaysQuote Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
unquotable = ByteString -> Builder
bl (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a. ToJSON a => a -> ByteString
Data.Aeson.encode Text
s
  -- otherwise; no quotes
  | Bool
otherwise = Builder
noQuote
  where
    noQuote :: Builder
noQuote = ByteString -> Builder
b (Text -> ByteString
Text.Encoding.encodeUtf8 Text
s)
    singleQuote :: Builder
singleQuote = ShortByteString -> Builder
bs "'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
noQuote Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ShortByteString -> Builder
bs "'"
    headS :: Char
headS = Text -> Char
Text.head Text
s
    unquotable :: Bool
unquotable -- s is unquotable if all are True
     =
      Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "" Bool -> Bool -> Bool
&& -- s is not empty
      (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
isAllowed Text
s Bool -> Bool -> Bool
&& -- s consists of acceptable chars
      (Char -> Bool
Data.Char.isAlpha Char
headS Bool -> Bool -> Bool
|| -- head of s is a char in A-Z or a-z or indicates a filepath
       Char
headS Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/')
    isBoolString :: Bool
isBoolString
      | Text -> Int
Text.length Text
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 5 = Bool
False
      | Bool
otherwise =
        case Text -> Text
Text.toLower Text
s of
          "true" -> Bool
True
          "false" -> Bool
True
          _ -> Bool
False
    isSafeAscii :: Char -> Bool
isSafeAscii c :: Char
c =
      (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= 'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= 'z') Bool -> Bool -> Bool
||
      (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= 'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= 'Z') Bool -> Bool -> Bool
||
      (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '9') Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '='
    isNumberOrDateRelated :: Char -> Bool
isNumberOrDateRelated c :: Char
c = Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'e' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-'
    isAllowed :: Char -> Bool
isAllowed c :: Char
c = Char -> Bool
isSafeAscii Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' '

encodeLines :: Int -> [Text] -> Builder
encodeLines :: Int -> [Text] -> Builder
encodeLines level :: Int
level ls :: [Text]
ls =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$
  (Builder
prefix Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
:) ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$
  Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (ShortByteString -> Builder
bs "\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
indent Int
level) ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ (Text -> Builder) -> [Text] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Builder
b (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.Encoding.encodeUtf8) [Text]
ls
  where
    prefix :: Builder
prefix =
      [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ ShortByteString -> Builder
bs "|"
        , if Bool
needsIndicator
            then ShortByteString -> Builder
bs "2"
            else Builder
forall a. Monoid a => a
mempty
        , "\n"
        , Int -> Builder
indent Int
level
        ]
    needsIndicator :: Bool
needsIndicator =
      case [Text]
ls of
        (line :: Text
line:_) -> " " Text -> Text -> Bool
`Text.isPrefixOf` Text
line
        _ -> Bool
False