{-# LANGUAGE DeriveFoldable      #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE DeriveTraversable   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
module HaskellCI.YamlSyntax (
    Yaml (..),
    reann,
    ToYaml (..),
    prettyYaml,
    -- * Helpers
    (~>),
    ykeyValuesFilt,
    ylistFilt,
    ) where

import HaskellCI.Prelude
import Prelude ()

import Data.Bits   (shiftR, (.&.))
import Data.Char   (isControl, isPrint, ord)
import Data.Monoid (Endo (..))

import qualified Data.Aeson              as Aeson
import qualified Data.Aeson.Encoding     as AE
import qualified Data.HashMap.Strict     as HM
import qualified Data.List.NonEmpty      as NE
import qualified Data.Map.Strict         as M
import qualified Data.Text               as T
import qualified Data.Text.Encoding      as TE
import qualified Data.Text.Lazy          as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.YAML               as YAML

import Numeric (showHex)

-- $setup
-- >>> :set -XOverloadedStrings

-------------------------------------------------------------------------------
-- Yaml syntx
-------------------------------------------------------------------------------

-- | This is not complete YAML document tree;
-- only as much as we need in @haskell-ci@.
data Yaml ann
    = YString ann String
    | YBool ann Bool
    | YList ann [Yaml ann]
    | YKeyValues ann [(ann, String, Yaml ann)]
    | YValue ann Aeson.Value  -- ^ inline JSON (for compactness)
  deriving (Yaml ann -> Yaml ann -> Bool
(Yaml ann -> Yaml ann -> Bool)
-> (Yaml ann -> Yaml ann -> Bool) -> Eq (Yaml ann)
forall ann. Eq ann => Yaml ann -> Yaml ann -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Yaml ann -> Yaml ann -> Bool
$c/= :: forall ann. Eq ann => Yaml ann -> Yaml ann -> Bool
== :: Yaml ann -> Yaml ann -> Bool
$c== :: forall ann. Eq ann => Yaml ann -> Yaml ann -> Bool
Eq, Int -> Yaml ann -> ShowS
[Yaml ann] -> ShowS
Yaml ann -> String
(Int -> Yaml ann -> ShowS)
-> (Yaml ann -> String) -> ([Yaml ann] -> ShowS) -> Show (Yaml ann)
forall ann. Show ann => Int -> Yaml ann -> ShowS
forall ann. Show ann => [Yaml ann] -> ShowS
forall ann. Show ann => Yaml ann -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Yaml ann] -> ShowS
$cshowList :: forall ann. Show ann => [Yaml ann] -> ShowS
show :: Yaml ann -> String
$cshow :: forall ann. Show ann => Yaml ann -> String
showsPrec :: Int -> Yaml ann -> ShowS
$cshowsPrec :: forall ann. Show ann => Int -> Yaml ann -> ShowS
Show, a -> Yaml b -> Yaml a
(a -> b) -> Yaml a -> Yaml b
(forall a b. (a -> b) -> Yaml a -> Yaml b)
-> (forall a b. a -> Yaml b -> Yaml a) -> Functor Yaml
forall a b. a -> Yaml b -> Yaml a
forall a b. (a -> b) -> Yaml a -> Yaml b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Yaml b -> Yaml a
$c<$ :: forall a b. a -> Yaml b -> Yaml a
fmap :: (a -> b) -> Yaml a -> Yaml b
$cfmap :: forall a b. (a -> b) -> Yaml a -> Yaml b
Functor, Yaml a -> Bool
(a -> m) -> Yaml a -> m
(a -> b -> b) -> b -> Yaml a -> b
(forall m. Monoid m => Yaml m -> m)
-> (forall m a. Monoid m => (a -> m) -> Yaml a -> m)
-> (forall m a. Monoid m => (a -> m) -> Yaml a -> m)
-> (forall a b. (a -> b -> b) -> b -> Yaml a -> b)
-> (forall a b. (a -> b -> b) -> b -> Yaml a -> b)
-> (forall b a. (b -> a -> b) -> b -> Yaml a -> b)
-> (forall b a. (b -> a -> b) -> b -> Yaml a -> b)
-> (forall a. (a -> a -> a) -> Yaml a -> a)
-> (forall a. (a -> a -> a) -> Yaml a -> a)
-> (forall a. Yaml a -> [a])
-> (forall a. Yaml a -> Bool)
-> (forall a. Yaml a -> Int)
-> (forall a. Eq a => a -> Yaml a -> Bool)
-> (forall a. Ord a => Yaml a -> a)
-> (forall a. Ord a => Yaml a -> a)
-> (forall a. Num a => Yaml a -> a)
-> (forall a. Num a => Yaml a -> a)
-> Foldable Yaml
forall a. Eq a => a -> Yaml a -> Bool
forall a. Num a => Yaml a -> a
forall a. Ord a => Yaml a -> a
forall m. Monoid m => Yaml m -> m
forall a. Yaml a -> Bool
forall a. Yaml a -> Int
forall a. Yaml a -> [a]
forall a. (a -> a -> a) -> Yaml a -> a
forall m a. Monoid m => (a -> m) -> Yaml a -> m
forall b a. (b -> a -> b) -> b -> Yaml a -> b
forall a b. (a -> b -> b) -> b -> Yaml a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Yaml a -> a
$cproduct :: forall a. Num a => Yaml a -> a
sum :: Yaml a -> a
$csum :: forall a. Num a => Yaml a -> a
minimum :: Yaml a -> a
$cminimum :: forall a. Ord a => Yaml a -> a
maximum :: Yaml a -> a
$cmaximum :: forall a. Ord a => Yaml a -> a
elem :: a -> Yaml a -> Bool
$celem :: forall a. Eq a => a -> Yaml a -> Bool
length :: Yaml a -> Int
$clength :: forall a. Yaml a -> Int
null :: Yaml a -> Bool
$cnull :: forall a. Yaml a -> Bool
toList :: Yaml a -> [a]
$ctoList :: forall a. Yaml a -> [a]
foldl1 :: (a -> a -> a) -> Yaml a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Yaml a -> a
foldr1 :: (a -> a -> a) -> Yaml a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Yaml a -> a
foldl' :: (b -> a -> b) -> b -> Yaml a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Yaml a -> b
foldl :: (b -> a -> b) -> b -> Yaml a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Yaml a -> b
foldr' :: (a -> b -> b) -> b -> Yaml a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Yaml a -> b
foldr :: (a -> b -> b) -> b -> Yaml a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Yaml a -> b
foldMap' :: (a -> m) -> Yaml a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Yaml a -> m
foldMap :: (a -> m) -> Yaml a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Yaml a -> m
fold :: Yaml m -> m
$cfold :: forall m. Monoid m => Yaml m -> m
Foldable, Functor Yaml
Foldable Yaml
Functor Yaml
-> Foldable Yaml
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Yaml a -> f (Yaml b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Yaml (f a) -> f (Yaml a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Yaml a -> m (Yaml b))
-> (forall (m :: * -> *) a. Monad m => Yaml (m a) -> m (Yaml a))
-> Traversable Yaml
(a -> f b) -> Yaml a -> f (Yaml b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Yaml (m a) -> m (Yaml a)
forall (f :: * -> *) a. Applicative f => Yaml (f a) -> f (Yaml a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Yaml a -> m (Yaml b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Yaml a -> f (Yaml b)
sequence :: Yaml (m a) -> m (Yaml a)
$csequence :: forall (m :: * -> *) a. Monad m => Yaml (m a) -> m (Yaml a)
mapM :: (a -> m b) -> Yaml a -> m (Yaml b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Yaml a -> m (Yaml b)
sequenceA :: Yaml (f a) -> f (Yaml a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Yaml (f a) -> f (Yaml a)
traverse :: (a -> f b) -> Yaml a -> f (Yaml b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Yaml a -> f (Yaml b)
$cp2Traversable :: Foldable Yaml
$cp1Traversable :: Functor Yaml
Traversable)

instance Monoid ann => IsString (Yaml ann) where
    fromString :: String -> Yaml ann
fromString = ann -> String -> Yaml ann
forall ann. ann -> String -> Yaml ann
YString ann
forall a. Monoid a => a
mempty

-- | Re-annotate top-level term
reann :: (ann -> ann) -> Yaml ann -> Yaml ann
reann :: (ann -> ann) -> Yaml ann -> Yaml ann
reann ann -> ann
f (YString ann
ann String
s)     = ann -> String -> Yaml ann
forall ann. ann -> String -> Yaml ann
YString (ann -> ann
f ann
ann) String
s
reann ann -> ann
f (YBool ann
ann Bool
b)       = ann -> Bool -> Yaml ann
forall ann. ann -> Bool -> Yaml ann
YBool (ann -> ann
f ann
ann) Bool
b
reann ann -> ann
f (YList ann
ann [Yaml ann]
xs)      = ann -> [Yaml ann] -> Yaml ann
forall ann. ann -> [Yaml ann] -> Yaml ann
YList (ann -> ann
f ann
ann) [Yaml ann]
xs
reann ann -> ann
f (YKeyValues ann
ann [(ann, String, Yaml ann)]
xs) = ann -> [(ann, String, Yaml ann)] -> Yaml ann
forall ann. ann -> [(ann, String, Yaml ann)] -> Yaml ann
YKeyValues (ann -> ann
f ann
ann) [(ann, String, Yaml ann)]
xs
reann ann -> ann
f (YValue ann
ann Value
v)      = ann -> Value -> Yaml ann
forall ann. ann -> Value -> Yaml ann
YValue (ann -> ann
f ann
ann) Value
v

-------------------------------------------------------------------------------
-- Class
-------------------------------------------------------------------------------

class ToYaml a where
    toYaml :: a -> Yaml [String]

instance ann ~ [String] => ToYaml (Yaml ann) where
    toYaml :: Yaml ann -> Yaml [String]
toYaml = Yaml ann -> Yaml [String]
forall a. a -> a
id

instance ToYaml Bool where
    toYaml :: Bool -> Yaml [String]
toYaml = [String] -> Bool -> Yaml [String]
forall ann. ann -> Bool -> Yaml ann
YBool []

instance ToYaml a => ToYaml [a] where
    toYaml :: [a] -> Yaml [String]
toYaml = [String] -> [Yaml [String]] -> Yaml [String]
forall ann. ann -> [Yaml ann] -> Yaml ann
YList [] ([Yaml [String]] -> Yaml [String])
-> ([a] -> [Yaml [String]]) -> [a] -> Yaml [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Yaml [String]) -> [a] -> [Yaml [String]]
forall a b. (a -> b) -> [a] -> [b]
map a -> Yaml [String]
forall a. ToYaml a => a -> Yaml [String]
toYaml

instance ToYaml Aeson.Value where
    toYaml :: Value -> Yaml [String]
toYaml = [String] -> Value -> Yaml [String]
forall ann. ann -> Value -> Yaml ann
YValue []

instance (k ~ String, ToYaml v) => ToYaml (M.Map k v) where
    toYaml :: Map k v -> Yaml [String]
toYaml Map k v
m = [String] -> [([String], String, Yaml [String])] -> Yaml [String]
forall ann. ann -> [(ann, String, Yaml ann)] -> Yaml ann
ykeyValuesFilt []
        [ k
String
k String -> Yaml [String] -> ([String], String, Yaml [String])
~> v -> Yaml [String]
forall a. ToYaml a => a -> Yaml [String]
toYaml v
v
        | (k
k, v
v) <- Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
M.toList Map k v
m
        ]

-------------------------------------------------------------------------------
-- Converting to string
-------------------------------------------------------------------------------

-- | Convert 'Yaml' to 'String'. @ann@ can be converted to comments.
--
-- == Examples
--
-- >>> let demo = putStr . prettyYaml lines
--
-- >>> demo "foo"
-- foo
--
-- >>> demo "foo: bar"
-- "foo: bar"
--
-- >>> demo $ YString "a comment" "foo"
-- # a comment
-- foo
--
-- >>> demo $ YBool "a comment" True
-- # a comment
-- true
--
-- >>> demo $ YList "" []
-- []
--
-- >>> demo $ YList "" ["foo", "foo: bar"]
-- - foo
-- - "foo: bar"
--
-- >>> demo $ YList "comment1" [YString "comment2" "foo", YString "comment3" "foo: bar"]
-- # comment1
-- #
-- # comment2
-- - foo
-- # comment3
-- - "foo: bar"
--
-- >>> demo $ YKeyValues "" []
-- {}
--
-- >>> demo $ YKeyValues "" [("", "foo", "bar"), ("", "help", "welcome")]
-- foo: bar
-- help: welcome
--
-- >>> let nested = YKeyValues "comment1" [("comment2", "foo", YString "comment3" "bar"), ("comment4", "help", YString "comment5" "welcome")]
-- >>> demo nested
-- # comment1
-- #
-- # comment2
-- #
-- # comment3
-- foo: bar
-- # comment4
-- #
-- # comment5
-- help: welcome
--
-- >>> demo $ YKeyValues "top" [("", "nested", nested)]
-- # top
-- nested:
--   # comment1
--   #
--   # comment2
--   #
--   # comment3
--   foo: bar
--   # comment4
--   #
--   # comment5
--   help: welcome
--
-- >>> demo $ YValue "inline json" $ Aeson.toJSON [True, False, True]
-- # inline json
-- [true,false,true]
--
-- >>> demo $ YKeyValues "" [ ("", "addons", YValue "" $ Aeson.toJSON $ [Just "foo", Just "bar", Nothing]) ]
-- addons: ["foo","bar",null]
--
-- >>> demo $ YString "" $ unlines ["foo","bar","baz"]
-- "foo\nbar\nbaz\n"
--
-- >>> let multiline = YString "" $ unlines ["foo", "bar", "baz"]
-- >>> demo $ YList "" [multiline, multiline]
-- - |
--   foo
--   bar
--   baz
-- - |
--   foo
--   bar
--   baz
--
-- >>> demo $ YKeyValues "" [("", "keyA", multiline), ("", "keyB", multiline)]
-- keyA: |
--   foo
--   bar
--   baz
-- keyB: |
--   foo
--   bar
--   baz
--
prettyYaml :: forall ann. (ann -> [String]) -> Yaml ann -> String
prettyYaml :: (ann -> [String]) -> Yaml ann -> String
prettyYaml ann -> [String]
comment' = NonEmpty (Int, Line) -> String
flatten (NonEmpty (Int, Line) -> String)
-> (Yaml ann -> NonEmpty (Int, Line)) -> Yaml ann -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Yaml ann -> NonEmpty (Int, Line)
go where
    comment :: ann -> [String]
    comment :: ann -> [String]
comment = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
lines' ([String] -> [String]) -> (ann -> [String]) -> ann -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ann -> [String]
comment' where
        lines' :: String -> [String]
lines' String
"" = [String
""]
        lines' String
s  = String -> [String]
lines String
s

    go :: Yaml ann -> NonEmpty (Int, Line)
    go :: Yaml ann -> NonEmpty (Int, Line)
go (YString ann
ann String
s) = case String -> Maybe ShowS
literal String
s of
        Just ShowS
ss -> (Int, Line) -> NonEmpty (Int, Line)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, [String] -> ShowS -> Line
Line (ann -> [String]
comment ann
ann) ShowS
ss)
        Maybe ShowS
Nothing -> (Int, Line) -> NonEmpty (Int, Line)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, [String] -> ShowS -> Line
Line (ann -> [String]
comment ann
ann) (ShowS -> Line) -> ShowS -> Line
forall a b. (a -> b) -> a -> b
$ String -> ShowS
encodeYAMLString String
s)

    go (YBool ann
ann Bool
b) =
        (Int, Line) -> NonEmpty (Int, Line)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, [String] -> ShowS -> Line
Line (ann -> [String]
comment ann
ann) (String -> ShowS
showString (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ if Bool
b then String
"true" else String
"false"))

    go (YValue ann
ann Value
v) =
        (Int, Line) -> NonEmpty (Int, Line)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, [String] -> ShowS -> Line
Line (ann -> [String]
comment ann
ann) (String -> ShowS
showString (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ Value -> String
encodeValue Value
v))

    go (YList ann
ann [])     = (Int, Line) -> NonEmpty (Int, Line)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, [String] -> ShowS -> Line
Line (ann -> [String]
comment ann
ann) (String -> ShowS
showString String
"[]"))
    go (YList ann
ann (Yaml ann
x:[Yaml ann]
xs)) = (Int, Line)
y (Int, Line) -> [(Int, Line)] -> NonEmpty (Int, Line)
forall a. a -> [a] -> NonEmpty a
:| ([(Int, Line)]
ys [(Int, Line)] -> [(Int, Line)] -> [(Int, Line)]
forall a. [a] -> [a] -> [a]
++ [(Int, Line)]
yss)
      where
        y :: (Int, Line)
        ys :: [(Int, Line)]
        ~((Int, Line)
y :| [(Int, Line)]
ys) = case Yaml ann -> Either ([String], [String]) (NonEmpty (Int, Line))
goSub Yaml ann
x of
            Right ((Int
_, Line [String]
cs ShowS
z) :| [(Int, Line)]
zs) ->
                (Int
0, [String] -> ShowS -> Line
Line (ann -> [String]
comment ann
ann [String] -> [String] -> [String]
+++ [String]
cs) (ShowS -> Line) -> ShowS -> Line
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"- " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
z) (Int, Line) -> [(Int, Line)] -> NonEmpty (Int, Line)
forall a. a -> [a] -> NonEmpty a
:|
                ((Int, Line) -> (Int, Line)) -> [(Int, Line)] -> [(Int, Line)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Int) -> (Int, Line) -> (Int, Line)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Int
forall a. Enum a => a -> a
succ) [(Int, Line)]
zs

            Left ([String]
cs, [String]
ls) ->
                (Int
0, [String] -> ShowS -> Line
Line (ann -> [String]
comment ann
ann [String] -> [String] -> [String]
+++ [String]
cs) (ShowS -> Line) -> ShowS -> Line
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"- |") (Int, Line) -> [(Int, Line)] -> NonEmpty (Int, Line)
forall a. a -> [a] -> NonEmpty a
:|
                [ (Int
1, [String] -> ShowS -> Line
Line [] (String -> ShowS
showString String
l))
                | String
l <- [String]
ls
                ]

        yss :: [(Int, Line)]
        yss :: [(Int, Line)]
yss = do
            Either ([String], [String]) (NonEmpty (Int, Line))
e <- Yaml ann -> Either ([String], [String]) (NonEmpty (Int, Line))
goSub (Yaml ann -> Either ([String], [String]) (NonEmpty (Int, Line)))
-> [Yaml ann]
-> [Either ([String], [String]) (NonEmpty (Int, Line))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Yaml ann]
xs
            case Either ([String], [String]) (NonEmpty (Int, Line))
e of
                Right ((Int
_, Line [String]
cs ShowS
z) :| [(Int, Line)]
zs) ->
                    (Int
0, [String] -> ShowS -> Line
Line [String]
cs (String -> ShowS
showString String
"- " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
z)) (Int, Line) -> [(Int, Line)] -> [(Int, Line)]
forall a. a -> [a] -> [a]
:
                    ((Int, Line) -> (Int, Line)) -> [(Int, Line)] -> [(Int, Line)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Int) -> (Int, Line) -> (Int, Line)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Int
forall a. Enum a => a -> a
succ) [(Int, Line)]
zs
                Left ([String]
cs, [String]
ls) ->
                    (Int
0, [String] -> ShowS -> Line
Line [String]
cs (ShowS -> Line) -> ShowS -> Line
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"- |") (Int, Line) -> [(Int, Line)] -> [(Int, Line)]
forall a. a -> [a] -> [a]
:
                    [ (Int
1, [String] -> ShowS -> Line
Line [] (String -> ShowS
showString String
l))
                    | String
l <- [String]
ls
                    ]

    go (YKeyValues ann
ann [])     = (Int, Line) -> NonEmpty (Int, Line)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, [String] -> ShowS -> Line
Line (ann -> [String]
comment ann
ann) (String -> ShowS
showString String
"{}"))
    go (YKeyValues ann
ann ((ann, String, Yaml ann)
x:[(ann, String, Yaml ann)]
xs)) = [String] -> (ann, String, Yaml ann) -> NonEmpty (Int, Line)
kv (ann -> [String]
comment ann
ann) (ann, String, Yaml ann)
x NonEmpty (Int, Line) -> [(Int, Line)] -> NonEmpty (Int, Line)
forall a. NonEmpty a -> [a] -> NonEmpty a
<+> ([(ann, String, Yaml ann)]
xs [(ann, String, Yaml ann)]
-> ((ann, String, Yaml ann) -> [(Int, Line)]) -> [(Int, Line)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NonEmpty (Int, Line) -> [(Int, Line)]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (Int, Line) -> [(Int, Line)])
-> ((ann, String, Yaml ann) -> NonEmpty (Int, Line))
-> (ann, String, Yaml ann)
-> [(Int, Line)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> (ann, String, Yaml ann) -> NonEmpty (Int, Line)
kv [])
      where
        kv :: [String] -> (ann, String, Yaml ann) -> NonEmpty (Int, Line)
        kv :: [String] -> (ann, String, Yaml ann) -> NonEmpty (Int, Line)
kv [String]
cs (ann
ann', String
k, Yaml ann
v) = case Yaml ann -> Either ([String], [String]) (NonEmpty (Int, Line))
goSub Yaml ann
v of
            -- single line
            Right ((Int
_, Line [String]
cs' ShowS
s) :| []) | Yaml ann -> Bool
forall a. Yaml a -> Bool
isScalar Yaml ann
v ->
                (Int
0, [String] -> ShowS -> Line
Line ([String]
cs [String] -> [String] -> [String]
+++ ann -> [String]
comment ann
ann' [String] -> [String] -> [String]
+++ [String]
cs') (ShowS -> Line) -> ShowS -> Line
forall a b. (a -> b) -> a -> b
$
                    String -> ShowS
showString String
k ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
": " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s) (Int, Line) -> [(Int, Line)] -> NonEmpty (Int, Line)
forall a. a -> [a] -> NonEmpty a
:|
                    []
            -- multiline non escaped
            Left ([String]
cs', [String]
ls) ->
                (Int
0, [String] -> ShowS -> Line
Line ([String]
cs [String] -> [String] -> [String]
+++ ann -> [String]
comment ann
ann' [String] -> [String] -> [String]
+++ [String]
cs') (ShowS -> Line) -> ShowS -> Line
forall a b. (a -> b) -> a -> b
$
                    String -> ShowS
showString String
k ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
": |") (Int, Line) -> [(Int, Line)] -> NonEmpty (Int, Line)
forall a. a -> [a] -> NonEmpty a
:|
                    [ (Int
1, [String] -> ShowS -> Line
Line [] (String -> ShowS
showString String
l))
                    | String
l <- [String]
ls
                    ]
            -- multiline
            Right NonEmpty (Int, Line)
vs ->
                (Int
0, [String] -> ShowS -> Line
Line ([String]
cs [String] -> [String] -> [String]
+++ ann -> [String]
comment ann
ann') (ShowS -> Line) -> ShowS -> Line
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
k ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
':') (Int, Line) -> [(Int, Line)] -> NonEmpty (Int, Line)
forall a. a -> [a] -> NonEmpty a
:|
                NonEmpty (Int, Line) -> [(Int, Line)]
forall a. NonEmpty a -> [a]
NE.toList (((Int, Line) -> (Int, Line))
-> NonEmpty (Int, Line) -> NonEmpty (Int, Line)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Int) -> (Int, Line) -> (Int, Line)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Int -> Int
forall a. Enum a => a -> a
succ) NonEmpty (Int, Line)
vs)

    -- which values can be on the same line with `:`
    isScalar :: Yaml ann -> Bool
isScalar YBool {}   = Bool
True
    isScalar YString {} = Bool
True
    isScalar YValue {}  = Bool
True
    isScalar Yaml ann
_          = Bool
False

    goSub :: Yaml ann -> Either ([String], [String]) (NonEmpty (Int, Line))
    goSub :: Yaml ann -> Either ([String], [String]) (NonEmpty (Int, Line))
goSub (YString ann
ann String
s) = case String -> Maybe ShowS
literal String
s of
        Just ShowS
ss -> NonEmpty (Int, Line)
-> Either ([String], [String]) (NonEmpty (Int, Line))
forall a b. b -> Either a b
Right ((Int, Line) -> NonEmpty (Int, Line)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, [String] -> ShowS -> Line
Line (ann -> [String]
comment ann
ann) ShowS
ss))
        Maybe ShowS
Nothing -> case String -> Maybe [String]
multiline String
s of
            Just [String]
ll -> ([String], [String])
-> Either ([String], [String]) (NonEmpty (Int, Line))
forall a b. a -> Either a b
Left (ann -> [String]
comment ann
ann, [String]
ll)
            Maybe [String]
Nothing -> NonEmpty (Int, Line)
-> Either ([String], [String]) (NonEmpty (Int, Line))
forall a b. b -> Either a b
Right ((Int, Line) -> NonEmpty (Int, Line)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, [String] -> ShowS -> Line
Line (ann -> [String]
comment ann
ann) (ShowS -> Line) -> ShowS -> Line
forall a b. (a -> b) -> a -> b
$ String -> ShowS
encodeYAMLString String
s))
    goSub Yaml ann
y = NonEmpty (Int, Line)
-> Either ([String], [String]) (NonEmpty (Int, Line))
forall a b. b -> Either a b
Right (Yaml ann -> NonEmpty (Int, Line)
go Yaml ann
y)

    -- given "foo" can it be encode without quotes:
    --
    --    foo
    --
    literal :: String -> Maybe ShowS
    literal :: String -> Maybe ShowS
literal String
s = case ByteString -> Either (Pos, String) [Text]
forall v. FromYAML v => ByteString -> Either (Pos, String) [v]
YAML.decodeStrict ByteString
bs of
        Right [Text
t'] | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t' -> ShowS -> Maybe ShowS
forall a. a -> Maybe a
Just (String -> ShowS
showString String
s)
        Either (Pos, String) [Text]
_                    -> Maybe ShowS
forall a. Maybe a
Nothing
      where
        t :: Text
t  = String -> Text
T.pack String
s
        bs :: ByteString
bs = Text -> ByteString
TE.encodeUtf8 Text
t

    -- when not top level, we can encode "foo\nbar\n" as
    --
    --     - |
    --       foo
    --       bar
    --
    -- Note: the input have to end with @\n@ for this to be triggered.
    --
    multiline :: String -> Maybe [String]
    multiline :: String -> Maybe [String]
multiline String
s = case ByteString -> Either (Pos, String) [[Text]]
forall v. FromYAML v => ByteString -> Either (Pos, String) [v]
YAML.decodeStrict ByteString
bs of
        Right [[Text
t']] | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t' -> [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
ls
        Either (Pos, String) [[Text]]
_                      -> Maybe [String]
forall a. Maybe a
Nothing
      where
        ls :: [String]
ls = String -> [String]
lines String
s
        t :: Text
t  = String -> Text
T.pack String
s

        ys :: String
ys = String
"- |\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
l -> String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n") [String]
ls
        yt :: Text
yt  = String -> Text
T.pack String
ys
        bs :: ByteString
bs = Text -> ByteString
TE.encodeUtf8 Text
yt

    -- when concatenating comment blocks, we add an empty line in between
    (+++) :: [String] -> [String] -> [String]
    [] +++ :: [String] -> [String] -> [String]
+++ [String]
xs = [String]
xs
    [String]
xs +++ [] = [String]
xs
    [String]
xs +++ [String]
ys = [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
""] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ys

    -- We can concatenate a list to a 'NonEmpty' list, the result is 'NonEmpty'.
    (<+>) :: NonEmpty a -> [a] -> NonEmpty a
    (a
x :| [a]
xs) <+> :: NonEmpty a -> [a] -> NonEmpty a
<+> [a]
ys = a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys)

    flatten :: NonEmpty (Int, Line) -> String
    flatten :: NonEmpty (Int, Line) -> String
flatten NonEmpty (Int, Line)
xs = Endo String -> ShowS
forall a. Endo a -> a -> a
appEndo (((Int, Line) -> Endo String) -> NonEmpty (Int, Line) -> Endo String
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int, Line) -> Endo String
f NonEmpty (Int, Line)
xs) String
"" where
        f :: (Int, Line) -> Endo String
f (Int
lvl, Line [String]
cs ShowS
s)
            | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ShowS
s String
"") = (String -> Endo String) -> [String] -> Endo String
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap String -> Endo String
showComment [String]
cs Endo String -> Endo String -> Endo String
forall a. Semigroup a => a -> a -> a
<> ShowS -> Endo String
forall a. (a -> a) -> Endo a
Endo (Char -> ShowS
showChar Char
'\n')
            | Bool
otherwise   = (String -> Endo String) -> [String] -> Endo String
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap String -> Endo String
showComment [String]
cs Endo String -> Endo String -> Endo String
forall a. Semigroup a => a -> a -> a
<> ShowS -> Endo String
g ShowS
s
          where
            showComment :: String -> Endo String
showComment String
"" = ShowS -> Endo String
g (String -> ShowS
showString String
"#")
            showComment String
c  = ShowS -> Endo String
g (String -> ShowS
showString String
"# " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
c)
            g :: ShowS -> Endo String
g ShowS
x = ShowS -> Endo String
forall a. (a -> a) -> Endo a
Endo (String -> ShowS
showString String
lvl' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\n')
            lvl' :: String
lvl' = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Char
' '

encodeValue :: Aeson.Value -> String
encodeValue :: Value -> String
encodeValue = Text -> String
TL.unpack (Text -> String) -> (Value -> Text) -> Value -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TLE.decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding' Value -> ByteString
forall a. Encoding' a -> ByteString
AE.encodingToLazyByteString (Encoding' Value -> ByteString)
-> (Value -> Encoding' Value) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Encoding' Value
enc where
    enc :: Aeson.Value -> Aeson.Encoding
    enc :: Value -> Encoding' Value
enc Value
Aeson.Null       = Encoding' Value
AE.null_
    enc (Aeson.Bool Bool
b)   = Bool -> Encoding' Value
AE.bool Bool
b
    enc (Aeson.Number Scientific
n) = Scientific -> Encoding' Value
AE.scientific Scientific
n
    enc (Aeson.String Text
s) = Text -> Encoding' Value
forall a. Text -> Encoding' a
AE.text Text
s
    enc (Aeson.Array Array
v)  = (Value -> Encoding' Value) -> [Value] -> Encoding' Value
forall a. (a -> Encoding' Value) -> [a] -> Encoding' Value
AE.list Value -> Encoding' Value
enc (Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
v)
    enc (Aeson.Object Object
m) = (Text -> Encoding' Text)
-> (Value -> Encoding' Value)
-> (forall a.
    (Text -> Value -> a -> a) -> a -> Map Text Value -> a)
-> Map Text Value
-> Encoding' Value
forall k v m.
(k -> Encoding' Text)
-> (v -> Encoding' Value)
-> (forall a. (k -> v -> a -> a) -> a -> m -> a)
-> m
-> Encoding' Value
AE.dict Text -> Encoding' Text
forall a. Text -> Encoding' a
AE.text Value -> Encoding' Value
enc forall a. (Text -> Value -> a -> a) -> a -> Map Text Value -> a
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey (Object -> Map Text Value
forall a. HashMap Text a -> Map Text a
toMap Object
m)

    toMap :: HashMap Text a -> Map Text a
toMap = [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, a)] -> Map Text a)
-> (HashMap Text a -> [(Text, a)]) -> HashMap Text a -> Map Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text a -> [(Text, a)]
forall k v. HashMap k v -> [(k, v)]
HM.toList

-- a 'Line' is comments before in and actual text after!
data Line = Line [String] ShowS

-- | Encode string to our best knowledge YAML string should be encoded.
-- Note: different than JSON
--
-- >>> putStrLn $ encodeYAMLString "\NULabcd\n" ""
-- "\x00abcd\n"
--
encodeYAMLString :: String -> ShowS
encodeYAMLString :: String -> ShowS
encodeYAMLString String
s
    = Char -> ShowS
showChar Char
'"'
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endo String -> ShowS
forall a. Endo a -> a -> a
appEndo ((Char -> Endo String) -> String -> Endo String
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ShowS -> Endo String
forall a. (a -> a) -> Endo a
Endo (ShowS -> Endo String) -> (Char -> ShowS) -> Char -> Endo String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
f) String
s)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'"'
  where
    f :: Char -> ShowS
    f :: Char -> ShowS
f Char
'\\' = String -> ShowS
showString String
"\\\\"
    f Char
'\n' = String -> ShowS
showString String
"\\n"
    f Char
'"'  = String -> ShowS
showString String
"\\\""
    f Char
c | Char -> Bool
isControl Char
c Bool -> Bool -> Bool
|| Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
128 Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isPrint Char
c)
        = Char -> ShowS
hexChar Char
c
        | Bool
otherwise
        = Char -> ShowS
showChar Char
c

-- | Produce a hex encoding of a character.
-- Uses two hex chars if they are enough, otherwise four.
-- For out of BMP characters, do nothing.
--
-- >>> putStrLn $ hexChar ' ' ""
-- \x20
--
-- >>> putStrLn $ hexChar '\1234' ""
-- \x04d2
--
hexChar :: Char -> ShowS
hexChar :: Char -> ShowS
hexChar Char
c
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
65536 = Char -> ShowS
showChar Char
c
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
256   = String -> ShowS
showString String
"\\x"
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
showHexDigit (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
n Int
16 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xf)
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
showHexDigit (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
n  Int
8 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xf)
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
showHexDigit (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
n  Int
4 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xf)
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
showHexDigit (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
n  Int
0 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xf)
    | Bool
otherwise = String -> ShowS
showString String
"\\x"
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
showHexDigit (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
n  Int
4 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xf)
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
showHexDigit (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
n  Int
0 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xf)
  where
    n :: Int
    n :: Int
n = Char -> Int
ord Char
c

    showHexDigit :: Int -> ShowS
    showHexDigit :: Int -> ShowS
showHexDigit = Int -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex

-------------------------------------------------------------------------------
-- Helpers
-------------------------------------------------------------------------------

(~>) :: String -> Yaml [String] -> ([String], String, Yaml [String])
String
k ~> :: String -> Yaml [String] -> ([String], String, Yaml [String])
~> Yaml [String]
v = ([],String
k,Yaml [String]
v)

ykeyValuesFilt :: ann -> [(ann, String, Yaml ann)] -> Yaml ann
ykeyValuesFilt :: ann -> [(ann, String, Yaml ann)] -> Yaml ann
ykeyValuesFilt ann
ann [(ann, String, Yaml ann)]
xs = ann -> [(ann, String, Yaml ann)] -> Yaml ann
forall ann. ann -> [(ann, String, Yaml ann)] -> Yaml ann
YKeyValues ann
ann
    [ (ann, String, Yaml ann)
x
    | x :: (ann, String, Yaml ann)
x@(ann
_,String
_,Yaml ann
y)  <- [(ann, String, Yaml ann)]
xs
    , Bool -> Bool
not (Yaml ann -> Bool
forall a. Yaml a -> Bool
isEmpty Yaml ann
y)
    ]

ylistFilt :: ann -> [Yaml ann] -> Yaml ann
ylistFilt :: ann -> [Yaml ann] -> Yaml ann
ylistFilt ann
ann [Yaml ann]
xs = ann -> [Yaml ann] -> Yaml ann
forall ann. ann -> [Yaml ann] -> Yaml ann
YList ann
ann
    [ Yaml ann
x
    | Yaml ann
x <- [Yaml ann]
xs
    , Bool -> Bool
not (Yaml ann -> Bool
forall a. Yaml a -> Bool
isEmpty Yaml ann
x)
    ]

isEmpty :: Yaml ann -> Bool
isEmpty :: Yaml ann -> Bool
isEmpty (YList ann
_ [])      = Bool
True
isEmpty (YKeyValues ann
_ []) = Bool
True
isEmpty Yaml ann
_                 = Bool
False