module B9.Artifact.Content.YamlObject
( YamlObject(..)
)
where
import B9.Text
import Control.Applicative
import Control.Parallel.Strategies
import Control.Exception
import Data.Bifunctor ( first )
import qualified Data.ByteString.Lazy as Lazy
import Data.Data
import Data.Function
import Data.Hashable
import Data.HashMap.Strict hiding ( singleton )
import Data.Semigroup
import Data.Vector as Vector
( singleton
, (++)
)
import Data.Yaml as Yaml
import GHC.Generics ( Generic )
import Prelude hiding ( (++) )
import Text.Printf
import B9.Artifact.Content
import B9.Artifact.Content.AST
import B9.Artifact.Content.StringTemplate
import Test.QuickCheck
newtype YamlObject = YamlObject
{ _fromYamlObject :: Yaml.Value
} deriving (Hashable, NFData, Eq, Data, Typeable, Generic)
instance Textual YamlObject where
renderToText = renderToText . encode . _fromYamlObject
parseFromText t = do
rb <- parseFromText t
y <- first displayException $ Yaml.decodeThrow (Lazy.toStrict rb)
return (YamlObject y)
instance Read YamlObject where
readsPrec _ = readsYamlObject
where
readsYamlObject :: ReadS YamlObject
readsYamlObject s =
[ (yamlFromString y, r2)
| ("YamlObject", r1) <- lex s
, (y , r2) <- reads r1
]
where
yamlFromString :: String -> YamlObject
yamlFromString =
either error id
. parseFromTextWithErrorMessage "HERE-DOC"
. unsafeRenderToText
instance Show YamlObject where
show (YamlObject o) = "YamlObject " <> show (unsafeRenderToText $ encode o)
instance Semigroup YamlObject where
(YamlObject v1) <> (YamlObject v2) = YamlObject (combine v1 v2)
where
combine :: Yaml.Value -> Yaml.Value -> Yaml.Value
combine (Object o1) (Object o2) = Object (unionWith combine o1 o2)
combine (Array a1) (Array a2) = Array (a1 ++ a2)
combine (Array a1) t2 = Array (a1 ++ Vector.singleton t2)
combine t1 (Array a2) = Array (Vector.singleton t1 ++ a2)
combine (String s1) (String s2) = String (s1 <> s2)
combine t1 t2 = array [t1, t2]
instance FromAST YamlObject where
fromAST ast = case ast of
ASTObj pairs -> do
ys <- mapM fromASTPair pairs
return (YamlObject (object ys))
ASTArr asts -> do
ys <- mapM fromAST asts
let ys' = (\(YamlObject o) -> o) <$> ys
return (YamlObject (array ys'))
ASTMerge [] -> error "ASTMerge MUST NOT be used with an empty list!"
ASTMerge asts -> do
ys <- mapM fromAST asts
return (foldl1 (<>) ys)
ASTEmbed c -> YamlObject . toJSON <$> toContentGenerator c
ASTString str -> return (YamlObject (toJSON str))
ASTInt int -> return (YamlObject (toJSON int))
ASTParse src@(Source _ srcPath) -> do
c <- readTemplateFile src
case parseFromTextWithErrorMessage srcPath c of
Right s -> return s
Left e -> error
(printf "could not parse yaml source file: '%s'\n%s\n" srcPath e)
AST a -> pure a
where
fromASTPair (key, value) = do
(YamlObject o) <- fromAST value
let key' = unsafeRenderToText key
return $ key' .= o
instance Arbitrary YamlObject where
arbitrary = pure (YamlObject Null)