module Hydra.Impl.Haskell.Ext.Yaml.Serde where

import Hydra.All
import Hydra.Ext.Yaml.Coder
import qualified Hydra.Ext.Yaml.Model as YM
import Hydra.Impl.Haskell.Ext.Bytestrings

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

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

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

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

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

yamlSerdeStr :: (Eq m, Ord m, Read m, Show m) => Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) String)
yamlSerdeStr :: forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) String)
yamlSerdeStr Type m
typ = do
  Coder (Context m) (Context m) (Term m) ByteString
serde <- forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) ByteString)
yamlSerde Type m
typ
  forall (m :: * -> *) a. Monad m => a -> m a
return Coder {
    coderEncode :: Term m -> Flow (Context m) String
coderEncode = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> String
LB.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder (Context m) (Context m) (Term m) ByteString
serde,
    coderDecode :: String -> Flow (Context m) (Term m)
coderDecode = forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder (Context m) (Context m) (Term m) ByteString
serde forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
LB.pack}