-- | A wrapper around Yaml with 'Semigroup' and 'Monoid' instances for merging, reading and
-- writing yaml files within B9.
module B9.Artifact.Content.YamlObject
  ( YamlObject (..),
  )
where

import B9.Artifact.Content
import B9.Artifact.Content.AST
import B9.Artifact.Content.StringTemplate
import B9.Text
import Control.Applicative
import Control.Exception
import Control.Parallel.Strategies
import Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as Lazy
import Data.Data
import Data.Function
import Data.HashMap.Strict hiding (singleton)
import Data.Hashable
import Data.Semigroup
import Data.Vector as Vector
  ( (++),
    singleton,
  )
import Data.Yaml as Yaml
import GHC.Generics (Generic)
import Test.QuickCheck
import Text.Printf
import Prelude hiding ((++))

-- | A wrapper type around yaml values with a Semigroup instance useful for
-- combining yaml documents describing system configuration like e.g. user-data.
newtype YamlObject
  = YamlObject
      { YamlObject -> Value
_fromYamlObject :: Yaml.Value
      }
  deriving (Int -> YamlObject -> Int
YamlObject -> Int
(Int -> YamlObject -> Int)
-> (YamlObject -> Int) -> Hashable YamlObject
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: YamlObject -> Int
$chash :: YamlObject -> Int
hashWithSalt :: Int -> YamlObject -> Int
$chashWithSalt :: Int -> YamlObject -> Int
Hashable, YamlObject -> ()
(YamlObject -> ()) -> NFData YamlObject
forall a. (a -> ()) -> NFData a
rnf :: YamlObject -> ()
$crnf :: YamlObject -> ()
NFData, YamlObject -> YamlObject -> Bool
(YamlObject -> YamlObject -> Bool)
-> (YamlObject -> YamlObject -> Bool) -> Eq YamlObject
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: YamlObject -> YamlObject -> Bool
$c/= :: YamlObject -> YamlObject -> Bool
== :: YamlObject -> YamlObject -> Bool
$c== :: YamlObject -> YamlObject -> Bool
Eq, Typeable YamlObject
DataType
Constr
Typeable YamlObject
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> YamlObject -> c YamlObject)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c YamlObject)
-> (YamlObject -> Constr)
-> (YamlObject -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c YamlObject))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c YamlObject))
-> ((forall b. Data b => b -> b) -> YamlObject -> YamlObject)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> YamlObject -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> YamlObject -> r)
-> (forall u. (forall d. Data d => d -> u) -> YamlObject -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> YamlObject -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> YamlObject -> m YamlObject)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> YamlObject -> m YamlObject)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> YamlObject -> m YamlObject)
-> Data YamlObject
YamlObject -> DataType
YamlObject -> Constr
(forall b. Data b => b -> b) -> YamlObject -> YamlObject
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> YamlObject -> c YamlObject
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c YamlObject
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> YamlObject -> u
forall u. (forall d. Data d => d -> u) -> YamlObject -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> YamlObject -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> YamlObject -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> YamlObject -> m YamlObject
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> YamlObject -> m YamlObject
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c YamlObject
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> YamlObject -> c YamlObject
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c YamlObject)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c YamlObject)
$cYamlObject :: Constr
$tYamlObject :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> YamlObject -> m YamlObject
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> YamlObject -> m YamlObject
gmapMp :: (forall d. Data d => d -> m d) -> YamlObject -> m YamlObject
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> YamlObject -> m YamlObject
gmapM :: (forall d. Data d => d -> m d) -> YamlObject -> m YamlObject
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> YamlObject -> m YamlObject
gmapQi :: Int -> (forall d. Data d => d -> u) -> YamlObject -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> YamlObject -> u
gmapQ :: (forall d. Data d => d -> u) -> YamlObject -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> YamlObject -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> YamlObject -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> YamlObject -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> YamlObject -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> YamlObject -> r
gmapT :: (forall b. Data b => b -> b) -> YamlObject -> YamlObject
$cgmapT :: (forall b. Data b => b -> b) -> YamlObject -> YamlObject
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c YamlObject)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c YamlObject)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c YamlObject)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c YamlObject)
dataTypeOf :: YamlObject -> DataType
$cdataTypeOf :: YamlObject -> DataType
toConstr :: YamlObject -> Constr
$ctoConstr :: YamlObject -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c YamlObject
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c YamlObject
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> YamlObject -> c YamlObject
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> YamlObject -> c YamlObject
$cp1Data :: Typeable YamlObject
Data, Typeable, (forall x. YamlObject -> Rep YamlObject x)
-> (forall x. Rep YamlObject x -> YamlObject) -> Generic YamlObject
forall x. Rep YamlObject x -> YamlObject
forall x. YamlObject -> Rep YamlObject x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep YamlObject x -> YamlObject
$cfrom :: forall x. YamlObject -> Rep YamlObject x
Generic)

instance Textual YamlObject where
  renderToText :: YamlObject -> Either String Text
renderToText = ByteString -> Either String Text
forall a. (Textual a, HasCallStack) => a -> Either String Text
renderToText (ByteString -> Either String Text)
-> (YamlObject -> ByteString) -> YamlObject -> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString)
-> (YamlObject -> Value) -> YamlObject -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. YamlObject -> Value
_fromYamlObject
  parseFromText :: Text -> Either String YamlObject
parseFromText Text
t = do
    ByteString
rb <- Text -> Either String ByteString
forall a. (Textual a, HasCallStack) => Text -> Either String a
parseFromText Text
t
    Value
y <- (SomeException -> String)
-> Either SomeException Value -> Either String Value
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SomeException -> String
forall e. Exception e => e -> String
displayException (Either SomeException Value -> Either String Value)
-> Either SomeException Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Either SomeException Value
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Yaml.decodeThrow (ByteString -> ByteString
Lazy.toStrict ByteString
rb)
    YamlObject -> Either String YamlObject
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> YamlObject
YamlObject Value
y)

instance Read YamlObject where
  readsPrec :: Int -> ReadS YamlObject
readsPrec Int
_ = ReadS YamlObject
readsYamlObject
    where
      readsYamlObject :: ReadS YamlObject
      readsYamlObject :: ReadS YamlObject
readsYamlObject String
s =
        [ (String -> YamlObject
yamlFromString String
y, String
r2)
          | (String
"YamlObject", String
r1) <- ReadS String
lex String
s,
            (String
y, String
r2) <- ReadS String
forall a. Read a => ReadS a
reads String
r1
        ]
        where
          yamlFromString :: String -> YamlObject
          yamlFromString :: String -> YamlObject
yamlFromString =
            (String -> YamlObject)
-> (YamlObject -> YamlObject)
-> Either String YamlObject
-> YamlObject
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> YamlObject
forall a. HasCallStack => String -> a
error YamlObject -> YamlObject
forall a. a -> a
id
              (Either String YamlObject -> YamlObject)
-> (String -> Either String YamlObject) -> String -> YamlObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> Either String YamlObject
forall a.
(HasCallStack, Textual a) =>
String -> Text -> Either String a
parseFromTextWithErrorMessage String
"HERE-DOC"
              (Text -> Either String YamlObject)
-> (String -> Text) -> String -> Either String YamlObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. (Textual a, HasCallStack) => a -> Text
unsafeRenderToText

instance Show YamlObject where
  show :: YamlObject -> String
show (YamlObject Value
o) = String
"YamlObject " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show (ByteString -> Text
forall a. (Textual a, HasCallStack) => a -> Text
unsafeRenderToText (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
o)

instance Semigroup YamlObject where
  (YamlObject Value
v1) <> :: YamlObject -> YamlObject -> YamlObject
<> (YamlObject Value
v2) = Value -> YamlObject
YamlObject (Value -> Value -> Value
combine Value
v1 Value
v2)
    where
      combine :: Yaml.Value -> Yaml.Value -> Yaml.Value
      combine :: Value -> Value -> Value
combine (Object Object
o1) (Object Object
o2) = Object -> Value
Object ((Value -> Value -> Value) -> Object -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
unionWith Value -> Value -> Value
combine Object
o1 Object
o2)
      combine (Array Array
a1) (Array Array
a2) = Array -> Value
Array (Array
a1 Array -> Array -> Array
forall a. Vector a -> Vector a -> Vector a
++ Array
a2)
      combine (Array Array
a1) Value
t2 = Array -> Value
Array (Array
a1 Array -> Array -> Array
forall a. Vector a -> Vector a -> Vector a
++ Value -> Array
forall a. a -> Vector a
Vector.singleton Value
t2)
      combine Value
t1 (Array Array
a2) = Array -> Value
Array (Value -> Array
forall a. a -> Vector a
Vector.singleton Value
t1 Array -> Array -> Array
forall a. Vector a -> Vector a -> Vector a
++ Array
a2)
      combine (String Text
s1) (String Text
s2) = Text -> Value
String (Text
s1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s2)
      combine Value
t1 Value
t2 = [Value] -> Value
array [Value
t1, Value
t2]

instance FromAST YamlObject where
  fromAST :: AST c YamlObject -> Eff e YamlObject
fromAST AST c YamlObject
ast = case AST c YamlObject
ast of
    ASTObj [(String, AST c YamlObject)]
pairs -> do
      [Pair]
ys <- ((String, AST c YamlObject) -> Eff e Pair)
-> [(String, AST c YamlObject)] -> Eff e [Pair]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, AST c YamlObject) -> Eff e Pair
forall (e :: [* -> *]) b a c.
(SetMember Lift (Lift IO) e, KeyValue b, Textual a,
 ToContentGenerator c, FindElem (Exc SomeException) e,
 FindElem (Reader Environment) e, FindElem (Reader BuildInfo) e,
 FindElem (Reader RepoCache) e,
 FindElem (Reader SelectedRemoteRepo) e,
 FindElem (Reader B9Config) e, FindElem (Reader Logger) e,
 MonadBaseControl IO (Eff e)) =>
(a, AST c YamlObject) -> Eff e b
fromASTPair [(String, AST c YamlObject)]
pairs
      YamlObject -> Eff e YamlObject
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> YamlObject
YamlObject ([Pair] -> Value
object [Pair]
ys))
    ASTArr [AST c YamlObject]
asts -> do
      [YamlObject]
ys <- (AST c YamlObject -> Eff e YamlObject)
-> [AST c YamlObject] -> Eff e [YamlObject]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AST c YamlObject -> Eff e YamlObject
forall a (e :: [* -> *]) c.
(FromAST a, IsB9 e, ToContentGenerator c) =>
AST c a -> Eff e a
fromAST [AST c YamlObject]
asts
      let ys' :: [Value]
ys' = (\(YamlObject Value
o) -> Value
o) (YamlObject -> Value) -> [YamlObject] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [YamlObject]
ys
      YamlObject -> Eff e YamlObject
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> YamlObject
YamlObject ([Value] -> Value
array [Value]
ys'))
    ASTMerge [] -> String -> Eff e YamlObject
forall a. HasCallStack => String -> a
error String
"ASTMerge MUST NOT be used with an empty list!"
    ASTMerge [AST c YamlObject]
asts -> do
      [YamlObject]
ys <- (AST c YamlObject -> Eff e YamlObject)
-> [AST c YamlObject] -> Eff e [YamlObject]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AST c YamlObject -> Eff e YamlObject
forall a (e :: [* -> *]) c.
(FromAST a, IsB9 e, ToContentGenerator c) =>
AST c a -> Eff e a
fromAST [AST c YamlObject]
asts
      YamlObject -> Eff e YamlObject
forall (m :: * -> *) a. Monad m => a -> m a
return ((YamlObject -> YamlObject -> YamlObject)
-> [YamlObject] -> YamlObject
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 YamlObject -> YamlObject -> YamlObject
forall a. Semigroup a => a -> a -> a
(<>) [YamlObject]
ys)
    ASTEmbed c
c -> Value -> YamlObject
YamlObject (Value -> YamlObject) -> (Text -> Value) -> Text -> YamlObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> YamlObject) -> Eff e Text -> Eff e YamlObject
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> Eff e Text
forall c (e :: [* -> *]).
(ToContentGenerator c, HasCallStack, IsB9 e) =>
c -> Eff e Text
toContentGenerator c
c
    ASTString String
str -> YamlObject -> Eff e YamlObject
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> YamlObject
YamlObject (String -> Value
forall a. ToJSON a => a -> Value
toJSON String
str))
    ASTInt Int
int -> YamlObject -> Eff e YamlObject
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> YamlObject
YamlObject (Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
int))
    ASTParse src :: SourceFile
src@(Source SourceFileConversion
_ String
srcPath) -> do
      Text
c <- SourceFile -> Eff e Text
forall (e :: [* -> *]).
(MonadIO (Eff e),
 '[Exc SomeException, Reader Environment] <:: e) =>
SourceFile -> Eff e Text
readTemplateFile SourceFile
src
      case String -> Text -> Either String YamlObject
forall a.
(HasCallStack, Textual a) =>
String -> Text -> Either String a
parseFromTextWithErrorMessage String
srcPath Text
c of
        Right YamlObject
s -> YamlObject -> Eff e YamlObject
forall (m :: * -> *) a. Monad m => a -> m a
return YamlObject
s
        Left String
e ->
          String -> Eff e YamlObject
forall a. HasCallStack => String -> a
error
            (String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"could not parse yaml source file: '%s'\n%s\n" String
srcPath String
e)
    AST YamlObject
a -> YamlObject -> Eff e YamlObject
forall (f :: * -> *) a. Applicative f => a -> f a
pure YamlObject
a
    where
      fromASTPair :: (a, AST c YamlObject) -> Eff e b
fromASTPair (a
key, AST c YamlObject
value) = do
        (YamlObject Value
o) <- AST c YamlObject -> Eff e YamlObject
forall a (e :: [* -> *]) c.
(FromAST a, IsB9 e, ToContentGenerator c) =>
AST c a -> Eff e a
fromAST AST c YamlObject
value
        let key' :: Text
key' = a -> Text
forall a. (Textual a, HasCallStack) => a -> Text
unsafeRenderToText a
key
        b -> Eff e b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Eff e b) -> b -> Eff e b
forall a b. (a -> b) -> a -> b
$ Text
key' Text -> Value -> b
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
o

instance Arbitrary YamlObject where
  arbitrary :: Gen YamlObject
arbitrary = YamlObject -> Gen YamlObject
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> YamlObject
YamlObject Value
Null)