haskell-ci-0.4: src/HaskellCI/YamlSyntax.hs
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
module HaskellCI.YamlSyntax (
Yaml (..),
reann,
ToYaml (..),
prettyYaml,
) where
import Prelude ()
import Prelude.Compat
import Data.Bifunctor (first)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Monoid (Endo (..))
import Data.String (IsString (..))
import qualified Data.Aeson as Aeson
import qualified Data.List.NonEmpty as NE
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
-- $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 (Eq, Show, Functor, Foldable, Traversable)
instance Monoid ann => IsString (Yaml ann) where
fromString = YString mempty
-- | Re-annotate top-level term
reann :: (ann -> ann) -> Yaml ann -> Yaml ann
reann f (YString ann s) = YString (f ann) s
reann f (YBool ann b) = YBool (f ann) b
reann f (YList ann xs) = YList (f ann) xs
reann f (YKeyValues ann xs) = YKeyValues (f ann) xs
reann f (YValue ann v) = YValue (f ann) v
-------------------------------------------------------------------------------
-- Class
-------------------------------------------------------------------------------
class ToYaml a where
toYaml :: a -> Yaml [String]
instance ann ~ [String] => ToYaml (Yaml ann) where
toYaml = id
instance ToYaml Bool where
toYaml = YBool []
instance ToYaml a => ToYaml [a] where
toYaml = YList [] . map toYaml
instance ToYaml Aeson.Value where
toYaml = YValue []
-------------------------------------------------------------------------------
-- 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 comment' = flatten . go where
comment :: ann -> [String]
comment = concatMap lines' . comment' where
lines' "" = [""]
lines' s = lines s
go :: Yaml ann -> NonEmpty (Int, Line)
go (YString ann s) = case literal s of
Just ss -> pure (0, Line (comment ann) ss)
Nothing -> pure (0, Line (comment ann) (shows s))
go (YBool ann b) =
pure (0, Line (comment ann) (showString $ if b then "true" else "false"))
go (YValue ann v) =
pure (0, Line (comment ann) (showString $ TL.unpack $ TLE.decodeUtf8 $ Aeson.encode v))
go (YList ann []) = pure (0, Line (comment ann) (showString "[]"))
go (YList ann (x:xs)) = y :| (ys ++ yss)
where
y :: (Int, Line)
ys :: [(Int, Line)]
~(y :| ys) = case goSub x of
Right ((_, Line cs z) :| zs) ->
(0, Line (comment ann +++ cs) $ showString "- " . z) :|
fmap (first succ) zs
Left (cs, ls) ->
(0, Line (comment ann +++ cs) $ showString "- |") :|
[ (1, Line [] (showString l))
| l <- ls
]
yss :: [(Int, Line)]
yss = do
e <- goSub <$> xs
case e of
Right ((_, Line cs z) :| zs) ->
(0, Line cs (showString "- " . z)) :
fmap (first succ) zs
Left (cs, ls) ->
(0, Line cs $ showString "- |") :
[ (1, Line [] (showString l))
| l <- ls
]
go (YKeyValues ann []) = pure (0, Line (comment ann) (showString "{}"))
go (YKeyValues ann (x:xs)) = kv (comment ann) x <+> (xs >>= NE.toList . kv [])
where
kv :: [String] -> (ann, String, Yaml ann) -> NonEmpty (Int, Line)
kv cs (ann', k, v) = case goSub v of
-- single line
Right ((_, Line cs' s) :| []) | isScalar v ->
(0, Line (cs +++ comment ann' +++ cs') $
showString k . showString ": " . s) :|
[]
-- multiline non escaped
Left (cs', ls) ->
(0, Line (cs +++ comment ann' +++ cs') $
showString k . showString ": |") :|
[ (1, Line [] (showString l))
| l <- ls
]
-- multiline
Right vs ->
(0, Line (cs +++ comment ann') $ showString k . showChar ':') :|
NE.toList (fmap (first succ) vs)
-- which values can be on the same line with `:`
isScalar YBool {} = True
isScalar YString {} = True
isScalar YValue {} = True
isScalar _ = False
goSub :: Yaml ann -> Either ([String], [String]) (NonEmpty (Int, Line))
goSub (YString ann s) = case literal s of
Just ss -> Right (pure (0, Line (comment ann) ss))
Nothing -> case multiline s of
Just ll -> Left (comment ann, ll)
Nothing -> Right (pure (0, Line (comment ann) (shows s)))
goSub y = Right (go y)
-- given "foo" can it be encode without quotes:
--
-- foo
--
literal :: String -> Maybe ShowS
literal s = case YAML.decodeStrict bs of
Right [t'] | t == t' -> Just (showString s)
_ -> Nothing
where
t = T.pack s
bs = TE.encodeUtf8 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 s = case YAML.decodeStrict bs of
Right [[t']] | t == t' -> Just ls
_ -> Nothing
where
ls = lines s
t = T.pack s
ys = "- |\n" ++ concatMap (\l -> " " ++ l ++ "\n") ls
yt = T.pack ys
bs = TE.encodeUtf8 yt
-- when concatenating comment blocks, we add an empty line in between
(+++) :: [String] -> [String] -> [String]
[] +++ xs = xs
xs +++ [] = xs
xs +++ ys = xs ++ [""] ++ ys
-- We can concatenate a list to a 'NonEmpty' list, the result is 'NonEmpty'.
(<+>) :: NonEmpty a -> [a] -> NonEmpty a
(x :| xs) <+> ys = x :| (xs ++ ys)
flatten :: NonEmpty (Int, Line) -> String
flatten xs = appEndo (foldMap f xs) "" where
f (lvl, Line cs s) =
foldMap showComment cs <> g s
where
showComment "" = g (showString "#")
showComment c = g (showString "# " . showString c)
g x = Endo (showString lvl' . x . showChar '\n')
lvl' = replicate (lvl * 2) ' '
-- a 'Line' is comments before in and actual text after!
data Line = Line [String] ShowS