module Hydra.Ext.Json.Coder (jsonCoder) where

import Hydra.All
import Hydra.Adapters.Term
import qualified Hydra.Impl.Haskell.Dsl.Terms as Terms
import qualified Hydra.Impl.Haskell.Dsl.Types as Types
import Hydra.Ext.Json.Language
import qualified Hydra.Ext.Json.Model as Json
import Hydra.Lib.Literals
import Hydra.Adapters.UtilsEtc

import qualified Control.Monad as CM
import qualified Data.Map as M
import qualified Data.Maybe as Y


jsonCoder :: (Eq m, Ord m, Read m, Show m) => Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) Json.Value)
jsonCoder :: forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) Value)
jsonCoder Type m
typ = do
    Context m
cx <- forall s. Flow s s
getState
    let acx :: AdapterContext m
acx = forall m. Context m -> Language m -> Language m -> AdapterContext m
AdapterContext Context m
cx forall m. Language m
hydraCoreLanguage forall m. Language m
jsonLanguage
    SymmetricAdapter (Context m) (Type m) (Term m)
adapter <- forall s1 a s2. s1 -> Flow s1 a -> Flow s2 a
withState AdapterContext m
acx forall a b. (a -> b) -> a -> b
$ forall m. (Ord m, Read m, Show m) => TypeAdapter m
termAdapter Type m
typ
    Coder (Context m) (Context m) (Term m) Value
coder <- forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) Value)
termCoder forall a b. (a -> b) -> a -> b
$ forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget SymmetricAdapter (Context m) (Type m) (Term m)
adapter
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s a b c. Coder s s a b -> Coder s s b c -> Coder s s a c
composeCoders (forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder SymmetricAdapter (Context m) (Type m) (Term m)
adapter) Coder (Context m) (Context m) (Term m) Value
coder

literalCoder :: LiteralType -> GraphFlow m (Coder (Context m) (Context m) Literal Json.Value)
literalCoder :: forall m.
LiteralType
-> GraphFlow m (Coder (Context m) (Context m) Literal Value)
literalCoder LiteralType
at = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case LiteralType
at of
  LiteralType
LiteralTypeBoolean -> Coder {
    coderEncode :: Literal -> Flow (Context m) Value
coderEncode = \(LiteralBoolean Bool
b) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> Value
Json.ValueBoolean Bool
b,
    coderDecode :: Value -> Flow (Context m) Literal
coderDecode = \Value
s -> case Value
s of
      Json.ValueBoolean Bool
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> Literal
LiteralBoolean Bool
b
      Value
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"boolean" Value
s}
  LiteralTypeFloat FloatType
_ -> Coder {
    coderEncode :: Literal -> Flow (Context m) Value
coderEncode = \(LiteralFloat (FloatValueBigfloat Double
f)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Double -> Value
Json.ValueNumber Double
f,
    coderDecode :: Value -> Flow (Context m) Literal
coderDecode = \Value
s -> case Value
s of
      Json.ValueNumber Double
f -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FloatValue -> Literal
LiteralFloat forall a b. (a -> b) -> a -> b
$ Double -> FloatValue
FloatValueBigfloat Double
f
      Value
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"number" Value
s}
  LiteralTypeInteger IntegerType
_ -> Coder {
    coderEncode :: Literal -> Flow (Context m) Value
coderEncode = \(LiteralInteger (IntegerValueBigint Integer
i)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Double -> Value
Json.ValueNumber forall a b. (a -> b) -> a -> b
$ Integer -> Double
bigintToBigfloat Integer
i,
    coderDecode :: Value -> Flow (Context m) Literal
coderDecode = \Value
s -> case Value
s of
      Json.ValueNumber Double
f -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ IntegerValue -> Literal
LiteralInteger forall a b. (a -> b) -> a -> b
$ Integer -> IntegerValue
IntegerValueBigint forall a b. (a -> b) -> a -> b
$ Double -> Integer
bigfloatToBigint Double
f
      Value
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"number" Value
s}
  LiteralType
LiteralTypeString -> Coder {
    coderEncode :: Literal -> Flow (Context m) Value
coderEncode = \(LiteralString String
s) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Value
Json.ValueString String
s,
    coderDecode :: Value -> Flow (Context m) Literal
coderDecode = \Value
s -> case Value
s of
      Json.ValueString String
s' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Literal
LiteralString String
s'
      Value
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"string" Value
s}

recordCoder :: (Eq m, Ord m, Read m, Show m) => RowType m -> GraphFlow m (Coder (Context m) (Context m) (Term m) Json.Value)
recordCoder :: forall m.
(Eq m, Ord m, Read m, Show m) =>
RowType m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) Value)
recordCoder RowType m
rt = do
    [(FieldType m, Coder (Context m) (Context m) (Term m) Value)]
coders <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
CM.mapM (\FieldType m
f -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldType m
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) Value)
termCoder (forall m. FieldType m -> Type m
fieldTypeType FieldType m
f)) (forall m. RowType m -> [FieldType m]
rowTypeFields RowType m
rt)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder (forall {m} {m} {s1} {s2}.
Show m =>
[(FieldType m, Coder s1 s2 (Term m) Value)]
-> Term m -> Flow s1 Value
encode [(FieldType m, Coder (Context m) (Context m) (Term m) Value)]
coders) (forall {m} {s1} {s2} {m}.
[(FieldType m, Coder s1 s2 (Term m) Value)]
-> Value -> Flow s2 (Term m)
decode [(FieldType m, Coder (Context m) (Context m) (Term m) Value)]
coders)
  where
    encode :: [(FieldType m, Coder s1 s2 (Term m) Value)]
-> Term m -> Flow s1 Value
encode [(FieldType m, Coder s1 s2 (Term m) Value)]
coders Term m
term = case forall m. Term m -> Term m
stripTerm Term m
term of
      TermRecord (Record Name
_ [Field m]
fields) -> Map String Value -> Value
Json.ValueObject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
Y.catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
CM.zipWithM forall {m} {s1} {s2} {m} {a}.
(FieldType m, Coder s1 s2 (Term m) a)
-> Field m -> Flow s1 (Maybe (String, a))
encodeField [(FieldType m, Coder s1 s2 (Term m) Value)]
coders [Field m]
fields
        where
          encodeField :: (FieldType m, Coder s1 s2 (Term m) a)
-> Field m -> Flow s1 (Maybe (String, a))
encodeField (FieldType m
ft, Coder s1 s2 (Term m) a
coder) (Field FieldName
fname Term m
fv) = case (forall m. FieldType m -> Type m
fieldTypeType FieldType m
ft, Term m
fv) of
            (TypeOptional Type m
_, TermOptional Maybe (Term m)
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            (Type m, Term m)
_ -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> String
unFieldName FieldName
fname) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder s1 s2 (Term m) a
coder Term m
fv)
      Term m
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"record" Term m
term
    decode :: [(FieldType m, Coder s1 s2 (Term m) Value)]
-> Value -> Flow s2 (Term m)
decode [(FieldType m, Coder s1 s2 (Term m) Value)]
coders Value
n = case Value
n of
      Json.ValueObject Map String Value
m -> forall m. Name -> [Field m] -> Term m
Terms.record (forall m. RowType m -> Name
rowTypeTypeName RowType m
rt) 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 {m} {s1} {s2} {m}.
Map String Value
-> (FieldType m, Coder s1 s2 (Term m) Value) -> Flow s2 (Field m)
decodeField Map String Value
m) [(FieldType m, Coder s1 s2 (Term m) Value)]
coders -- Note: unknown fields are ignored
        where
          decodeField :: Map String Value
-> (FieldType m, Coder s1 s2 (Term m) Value) -> Flow s2 (Field m)
decodeField Map String Value
m (FieldType FieldName
fname Type m
_, Coder s1 s2 (Term m) Value
coder) = do
            Term m
v <- forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder s1 s2 (Term m) Value
coder forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
Y.fromMaybe Value
Json.ValueNull forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (FieldName -> String
unFieldName FieldName
fname) Map String Value
m
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall m. FieldName -> Term m -> Field m
Field FieldName
fname Term m
v
      Value
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"mapping" Value
n
    getCoder :: Map String a -> String -> m a
getCoder Map String a
coders String
fname = forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe forall {a}. m a
error forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
fname Map String a
coders
      where
        error :: m a
error = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"no such field: " forall a. [a] -> [a] -> [a]
++ String
fname

termCoder :: (Eq m, Ord m, Read m, Show m) => Type m -> GraphFlow m (Coder (Context m) (Context m) (Term m) Json.Value)
termCoder :: forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) Value)
termCoder Type m
typ = case forall m. Type m -> Type m
stripType Type m
typ of
  TypeLiteral LiteralType
at -> do
    Coder (Context m) (Context m) Literal Value
ac <- forall m.
LiteralType
-> GraphFlow m (Coder (Context m) (Context m) Literal Value)
literalCoder LiteralType
at
    forall (m :: * -> *) a. Monad m => a -> m a
return Coder {
      coderEncode :: Term m -> Flow (Context m) Value
coderEncode = \(TermLiteral Literal
av) -> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder (Context m) (Context m) Literal Value
ac Literal
av,
      coderDecode :: Value -> Flow (Context m) (Term m)
coderDecode = \Value
n -> case Value
n of
        Value
s -> forall m. Literal -> Term m
Terms.literal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder (Context m) (Context m) Literal Value
ac Value
s}
  TypeList Type m
lt -> do
    Coder (Context m) (Context m) (Term m) Value
lc <- forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) Value)
termCoder Type m
lt
    forall (m :: * -> *) a. Monad m => a -> m a
return Coder {
      coderEncode :: Term m -> Flow (Context m) Value
coderEncode = \(TermList [Term m]
els) -> [Value] -> Value
Json.ValueArray 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 s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder (Context m) (Context m) (Term m) Value
lc) [Term m]
els,
      coderDecode :: Value -> Flow (Context m) (Term m)
coderDecode = \Value
n -> case Value
n of
        Json.ValueArray [Value]
nodes -> forall m. [Term m] -> Term m
Terms.list 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 s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder (Context m) (Context m) (Term m) Value
lc) [Value]
nodes
        Value
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"sequence" Value
n}
  TypeOptional Type m
ot -> do
    Coder (Context m) (Context m) (Term m) Value
oc <- forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) Value)
termCoder Type m
ot
    forall (m :: * -> *) a. Monad m => a -> m a
return Coder {
      coderEncode :: Term m -> Flow (Context m) Value
coderEncode = \Term m
t -> case Term m
t of
        TermOptional Maybe (Term m)
el -> forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Json.ValueNull) (forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder (Context m) (Context m) (Term m) Value
oc) Maybe (Term m)
el
        Term m
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"optional term" Term m
t,
      coderDecode :: Value -> Flow (Context m) (Term m)
coderDecode = \Value
n -> case Value
n of
        Value
Json.ValueNull -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall m. Maybe (Term m) -> Term m
Terms.optional forall a. Maybe a
Nothing
        Value
_ -> forall m. Maybe (Term m) -> Term m
Terms.optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder (Context m) (Context m) (Term m) Value
oc Value
n}
  TypeMap (MapType Type m
kt Type m
vt) -> do
      Coder (Context m) (Context m) (Term m) Value
kc <- forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) Value)
termCoder Type m
kt
      Coder (Context m) (Context m) (Term m) Value
vc <- forall m.
(Eq m, Ord m, Read m, Show m) =>
Type m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) Value)
termCoder Type m
vt
      Context m
cx <- forall s. Flow s s
getState
      let encodeEntry :: (Term m, Term m) -> Flow (Context m) (String, Value)
encodeEntry (Term m
k, Term m
v) = (,) (forall {m} {p}. Show m => p -> Term m -> String
toString Context m
cx Term m
k) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder (Context m) (Context m) (Term m) Value
vc Term m
v
      let decodeEntry :: (String, Value) -> Flow (Context m) (Term m, Term m)
decodeEntry (String
k, Value
v) = (,) (forall {p} {m}. p -> String -> Term m
fromString Context m
cx String
k) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder (Context m) (Context m) (Term m) Value
vc Value
v
      forall (m :: * -> *) a. Monad m => a -> m a
return Coder {
        coderEncode :: Term m -> Flow (Context m) Value
coderEncode = \(TermMap Map (Term m) (Term m)
m) -> Map String Value -> Value
Json.ValueObject 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 {m}.
Show m =>
(Term m, Term m) -> Flow (Context m) (String, Value)
encodeEntry (forall k a. Map k a -> [(k, a)]
M.toList Map (Term m) (Term m)
m),
        coderDecode :: Value -> Flow (Context m) (Term m)
coderDecode = \Value
n -> case Value
n of
          Json.ValueObject Map String Value
m -> forall m. Map (Term m) (Term m) -> Term m
Terms.map 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 {m}. (String, Value) -> Flow (Context m) (Term m, Term m)
decodeEntry (forall k a. Map k a -> [(k, a)]
M.toList Map String Value
m)
          Value
_ -> forall (m :: * -> *) a1 a2.
(MonadFail m, Show a1) =>
String -> a1 -> m a2
unexpected String
"mapping" Value
n}
    where
      toString :: p -> Term m -> String
toString p
cx Term m
v = if forall {p}. p -> Bool
isStringKey p
cx
        then case forall m. Term m -> Term m
stripTerm Term m
v of
          TermLiteral (LiteralString String
s) -> String
s
        else forall a. Show a => a -> String
show Term m
v
      fromString :: p -> String -> Term m
fromString p
cx String
s = forall m. String -> Term m
Terms.string forall a b. (a -> b) -> a -> b
$ if forall {p}. p -> Bool
isStringKey p
cx then String
s else forall a. Read a => String -> a
read String
s
      isStringKey :: p -> Bool
isStringKey p
cx = forall m. Type m -> Type m
stripType Type m
kt forall a. Eq a => a -> a -> Bool
== forall m. Type m
Types.string
  TypeRecord RowType m
rt -> forall m.
(Eq m, Ord m, Read m, Show m) =>
RowType m
-> GraphFlow m (Coder (Context m) (Context m) (Term m) Value)
recordCoder RowType m
rt