module Hydra.Langs.Yaml.Serde where

import Hydra.Kernel
import Hydra.Langs.Yaml.Coder
import Hydra.Tools.Bytestrings
import qualified Hydra.Langs.Yaml.Model as YM

import qualified Data.ByteString.Lazy as BS
import qualified Control.Monad as CM
import qualified Data.YAML as DY
import qualified Data.YAML.Event as DYE
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.ByteString.Lazy.Char8 as LB


bytesToHsYaml :: BS.ByteString -> Flow (Graph) (DY.Node DY.Pos)
bytesToHsYaml :: ByteString -> Flow Graph (Node Pos)
bytesToHsYaml ByteString
bs = case ByteString -> Either (Pos, String) [Doc (Node Pos)]
DY.decodeNode ByteString
bs of
    Left (Pos
pos, String
msg) -> String -> Flow Graph (Node Pos)
forall a. String -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow Graph (Node Pos))
-> String -> Flow Graph (Node Pos)
forall a b. (a -> b) -> a -> b
$ String
"YAML parser failure at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pos -> String
forall a. Show a => a -> String
show Pos
pos String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
    Right [Doc (Node Pos)]
docs -> if [Doc (Node Pos)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Doc (Node Pos)]
docs
      then String -> Flow Graph (Node Pos)
forall a. String -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no YAML document"
      else if [Doc (Node Pos)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [Doc (Node Pos)]
docs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
      then String -> Flow Graph (Node Pos)
forall a. String -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"multiple YAML documents"
      else case [Doc (Node Pos)] -> Doc (Node Pos)
forall a. HasCallStack => [a] -> a
L.head [Doc (Node Pos)]
docs of
        (DY.Doc Node Pos
node) -> Node Pos -> Flow Graph (Node Pos)
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Node Pos
node

bytesToHydraYaml :: BS.ByteString -> Flow (Graph) YM.Node
bytesToHydraYaml :: ByteString -> Flow Graph Node
bytesToHydraYaml = ByteString -> Flow Graph (Node Pos)
bytesToHsYaml (ByteString -> Flow Graph (Node Pos))
-> (Node Pos -> Flow Graph Node) -> ByteString -> Flow Graph Node
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
CM.>=> Node Pos -> Flow Graph Node
forall x. Node x -> Flow Graph Node
hsYamlToHydraYaml

hsYamlToBytes :: DY.Node () -> BS.ByteString
hsYamlToBytes :: Node () -> ByteString
hsYamlToBytes Node ()
node = [Doc (Node ())] -> ByteString
DY.encodeNode [Node () -> Doc (Node ())
forall n. n -> Doc n
DY.Doc Node ()
node]

hsYamlToHydraYaml :: DY.Node x -> Flow (Graph) YM.Node
hsYamlToHydraYaml :: forall x. Node x -> Flow Graph Node
hsYamlToHydraYaml Node x
hs = case Node x
hs of
  DY.Scalar x
_ Scalar
s -> Scalar -> Node
YM.NodeScalar (Scalar -> Node) -> Flow Graph Scalar -> Flow Graph Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Scalar
s of
     Scalar
DY.SNull -> Scalar -> Flow Graph Scalar
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scalar
YM.ScalarNull
     DY.SBool Bool
b -> Scalar -> Flow Graph Scalar
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scalar -> Flow Graph Scalar) -> Scalar -> Flow Graph Scalar
forall a b. (a -> b) -> a -> b
$ Bool -> Scalar
YM.ScalarBool Bool
b
     DY.SFloat Double
f -> Scalar -> Flow Graph Scalar
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scalar -> Flow Graph Scalar) -> Scalar -> Flow Graph Scalar
forall a b. (a -> b) -> a -> b
$ Double -> Scalar
YM.ScalarFloat Double
f
     DY.SInt Integer
i -> Scalar -> Flow Graph Scalar
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scalar -> Flow Graph Scalar) -> Scalar -> Flow Graph Scalar
forall a b. (a -> b) -> a -> b
$ Integer -> Scalar
YM.ScalarInt Integer
i
     DY.SStr Text
t -> Scalar -> Flow Graph Scalar
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scalar -> Flow Graph Scalar) -> Scalar -> Flow Graph Scalar
forall a b. (a -> b) -> a -> b
$ String -> Scalar
YM.ScalarStr (String -> Scalar) -> String -> Scalar
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
     DY.SUnknown Tag
_ Text
_ -> String -> Flow Graph Scalar
forall a. String -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"YAML unknown scalars are unsupported"
  DY.Mapping x
_ Tag
_ Mapping x
m -> Map Node Node -> Node
YM.NodeMapping (Map Node Node -> Node)
-> ([(Node, Node)] -> Map Node Node) -> [(Node, Node)] -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Node, Node)] -> Map Node Node
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Node, Node)] -> Node)
-> Flow Graph [(Node, Node)] -> Flow Graph Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Node x, Node x) -> Flow Graph (Node, Node))
-> [(Node x, Node x)] -> Flow Graph [(Node, Node)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM (Node x, Node x) -> Flow Graph (Node, Node)
forall {x} {x}. (Node x, Node x) -> Flow Graph (Node, Node)
mapPair (Mapping x -> [(Node x, Node x)]
forall k a. Map k a -> [(k, a)]
M.toList Mapping x
m)
    where
      mapPair :: (Node x, Node x) -> Flow Graph (Node, Node)
mapPair (Node x
k, Node x
v) = (,) (Node -> Node -> (Node, Node))
-> Flow Graph Node -> Flow Graph (Node -> (Node, Node))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node x -> Flow Graph Node
forall x. Node x -> Flow Graph Node
hsYamlToHydraYaml Node x
k Flow Graph (Node -> (Node, Node))
-> Flow Graph Node -> Flow Graph (Node, Node)
forall a b. Flow Graph (a -> b) -> Flow Graph a -> Flow Graph b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node x -> Flow Graph Node
forall x. Node x -> Flow Graph Node
hsYamlToHydraYaml Node x
v
  DY.Sequence x
_ Tag
_ [Node x]
s -> [Node] -> Node
YM.NodeSequence ([Node] -> Node) -> Flow Graph [Node] -> Flow Graph Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node x -> Flow Graph Node) -> [Node x] -> Flow Graph [Node]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM Node x -> Flow Graph Node
forall x. Node x -> Flow Graph Node
hsYamlToHydraYaml [Node x]
s
  DY.Anchor {} -> String -> Flow Graph Node
forall a. String -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"YAML anchors are unsupported"

hydraYamlToBytes :: YM.Node -> BS.ByteString
hydraYamlToBytes :: Node -> ByteString
hydraYamlToBytes = Node () -> ByteString
hsYamlToBytes (Node () -> ByteString) -> (Node -> Node ()) -> Node -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Node ()
hydraYamlToHsYaml

hydraYamlToHsYaml :: YM.Node -> DY.Node ()
hydraYamlToHsYaml :: Node -> Node ()
hydraYamlToHsYaml Node
hy = case Node
hy of
  YM.NodeMapping Map Node Node
m -> () -> Tag -> Mapping () -> Node ()
forall loc. loc -> Tag -> Mapping loc -> Node loc
DY.Mapping () Tag
DYE.untagged (Mapping () -> Node ()) -> Mapping () -> Node ()
forall a b. (a -> b) -> a -> b
$ [(Node (), Node ())] -> Mapping ()
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Node (), Node ())] -> Mapping ())
-> [(Node (), Node ())] -> Mapping ()
forall a b. (a -> b) -> a -> b
$ (Node, Node) -> (Node (), Node ())
mapPair ((Node, Node) -> (Node (), Node ()))
-> [(Node, Node)] -> [(Node (), Node ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Node Node -> [(Node, Node)]
forall k a. Map k a -> [(k, a)]
M.toList Map Node Node
m
    where
      mapPair :: (Node, Node) -> (Node (), Node ())
mapPair (Node
k, Node
v) = (,) (Node -> Node ()
hydraYamlToHsYaml Node
k) (Node -> Node ()
hydraYamlToHsYaml Node
v)
  YM.NodeScalar Scalar
s -> () -> Scalar -> Node ()
forall loc. loc -> Scalar -> Node loc
DY.Scalar () (Scalar -> Node ()) -> Scalar -> Node ()
forall a b. (a -> b) -> a -> b
$ case Scalar
s of
    YM.ScalarBool Bool
b -> Bool -> Scalar
DY.SBool Bool
b
    YM.ScalarFloat Double
f -> Double -> Scalar
DY.SFloat Double
f
    YM.ScalarInt Integer
i -> Integer -> Scalar
DY.SInt Integer
i
    Scalar
YM.ScalarNull -> Scalar
DY.SNull
    YM.ScalarStr String
s -> Text -> Scalar
DY.SStr (Text -> Scalar) -> Text -> Scalar
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
  YM.NodeSequence [Node]
s -> () -> Tag -> [Node ()] -> Node ()
forall loc. loc -> Tag -> [Node loc] -> Node loc
DY.Sequence () Tag
DYE.untagged ([Node ()] -> Node ()) -> [Node ()] -> Node ()
forall a b. (a -> b) -> a -> b
$ Node -> Node ()
hydraYamlToHsYaml (Node -> Node ()) -> [Node] -> [Node ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Node]
s

hydraYamlToString :: YM.Node -> String
hydraYamlToString :: Node -> String
hydraYamlToString = ByteString -> String
bytesToString (ByteString -> String) -> (Node -> ByteString) -> Node -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> ByteString
hydraYamlToBytes

yamlByteStringCoder :: Type -> Flow (Graph) (Coder (Graph) (Graph) (Term) BS.ByteString)
yamlByteStringCoder :: Type -> Flow Graph (Coder Graph Graph Term ByteString)
yamlByteStringCoder Type
typ = do
  Coder Graph Graph Term Node
coder <- Type -> Flow Graph (Coder Graph Graph Term Node)
yamlCoder Type
typ
  Coder Graph Graph Term ByteString
-> Flow Graph (Coder Graph Graph Term ByteString)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return Coder {
    coderEncode :: Term -> Flow Graph ByteString
coderEncode = (Node -> ByteString) -> Flow Graph Node -> Flow Graph ByteString
forall a b. (a -> b) -> Flow Graph a -> Flow Graph b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> ByteString
hydraYamlToBytes (Flow Graph Node -> Flow Graph ByteString)
-> (Term -> Flow Graph Node) -> Term -> Flow Graph ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coder Graph Graph Term Node -> Term -> Flow Graph Node
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder Graph Graph Term Node
coder,
    coderDecode :: ByteString -> Flow Graph Term
coderDecode = ByteString -> Flow Graph Node
bytesToHydraYaml (ByteString -> Flow Graph Node)
-> (Node -> Flow Graph Term) -> ByteString -> Flow Graph Term
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
CM.>=> Coder Graph Graph Term Node -> Node -> Flow Graph Term
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder Graph Graph Term Node
coder}

yamlStringCoder :: Type -> Flow (Graph) (Coder (Graph) (Graph) (Term) String)
yamlStringCoder :: Type -> Flow Graph (Coder Graph Graph Term String)
yamlStringCoder Type
typ = do
  Coder Graph Graph Term ByteString
serde <- Type -> Flow Graph (Coder Graph Graph Term ByteString)
yamlByteStringCoder Type
typ
  Coder Graph Graph Term String
-> Flow Graph (Coder Graph Graph Term String)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return Coder {
    coderEncode :: Term -> Flow Graph String
coderEncode = (ByteString -> String)
-> Flow Graph ByteString -> Flow Graph String
forall a b. (a -> b) -> Flow Graph a -> Flow Graph b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> String
LB.unpack (Flow Graph ByteString -> Flow Graph String)
-> (Term -> Flow Graph ByteString) -> Term -> Flow Graph String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coder Graph Graph Term ByteString -> Term -> Flow Graph ByteString
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder Graph Graph Term ByteString
serde,
    coderDecode :: String -> Flow Graph Term
coderDecode = Coder Graph Graph Term ByteString -> ByteString -> Flow Graph Term
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder Graph Graph Term ByteString
serde (ByteString -> Flow Graph Term)
-> (String -> ByteString) -> String -> Flow Graph Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
LB.pack}