{-# LANGUAGE OverloadedStrings #-}
module Generics.SOP.JSON.Model (
JsonModel(..)
, gjsonModel
, Tagged(..)
, untag
) where
import Data.Aeson
import Data.Kind
import Data.String (fromString)
import Data.Tagged
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Vector as Vector
import Generics.SOP
import Generics.SOP.JSON
import Data.Time (UTCTime)
import Data.Text (Text)
class JsonModel (a :: Type) where
jsonModel :: Tagged a Value
instance JsonModel UTCTime where
jsonModel :: Tagged UTCTime Value
jsonModel = Value -> Tagged UTCTime Value
forall k (s :: k) b. b -> Tagged s b
Tagged (Value -> Tagged UTCTime Value) -> Value -> Tagged UTCTime Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"UTCTime"
instance JsonModel Text where
jsonModel :: Tagged Text Value
jsonModel = Value -> Tagged Text Value
forall k (s :: k) b. b -> Tagged s b
Tagged (Value -> Tagged Text Value) -> Value -> Tagged Text Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"String"
instance JsonModel Text.Lazy.Text where
jsonModel :: Tagged Text Value
jsonModel = Value -> Tagged Text Value
forall k (s :: k) b. b -> Tagged s b
Tagged (Value -> Tagged Text Value) -> Value -> Tagged Text Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"String"
instance {-# OVERLAPPING #-} JsonModel String where
jsonModel :: Tagged String Value
jsonModel = Value -> Tagged String Value
forall k (s :: k) b. b -> Tagged s b
Tagged (Value -> Tagged String Value) -> Value -> Tagged String Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"String"
instance JsonModel Int where
jsonModel :: Tagged Int Value
jsonModel = Value -> Tagged Int Value
forall k (s :: k) b. b -> Tagged s b
Tagged (Value -> Tagged Int Value) -> Value -> Tagged Int Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"Int"
instance JsonModel Double where
jsonModel :: Tagged Double Value
jsonModel = Value -> Tagged Double Value
forall k (s :: k) b. b -> Tagged s b
Tagged (Value -> Tagged Double Value) -> Value -> Tagged Double Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"Double"
instance JsonModel Rational where
jsonModel :: Tagged Rational Value
jsonModel = Value -> Tagged Rational Value
forall k (s :: k) b. b -> Tagged s b
Tagged (Value -> Tagged Rational Value) -> Value -> Tagged Rational Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"Rational"
instance JsonModel Bool where
jsonModel :: Tagged Bool Value
jsonModel = Value -> Tagged Bool Value
forall k (s :: k) b. b -> Tagged s b
Tagged (Value -> Tagged Bool Value) -> Value -> Tagged Bool Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"Bool"
instance {-# OVERLAPPABLE #-} JsonModel a => JsonModel [a] where
jsonModel :: Tagged [a] Value
jsonModel = let model :: Tagged a Value
model :: Tagged a Value
model = Tagged a Value
forall a. JsonModel a => Tagged a Value
jsonModel
in Value -> Tagged [a] Value
forall k (s :: k) b. b -> Tagged s b
Tagged (Value -> Tagged [a] Value) -> Value -> Tagged [a] Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Key
"List" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Tagged a Value -> Value
forall k (s :: k) b. Tagged s b -> b
untag Tagged a Value
model ]
instance {-# OVERLAPPABLE #-} JsonModel a => JsonModel (Maybe a) where
jsonModel :: Tagged (Maybe a) Value
jsonModel = let model :: Tagged a Value
model :: Tagged a Value
model = Tagged a Value
forall a. JsonModel a => Tagged a Value
jsonModel
in Value -> Tagged (Maybe a) Value
forall k (s :: k) b. b -> Tagged s b
Tagged (Value -> Tagged (Maybe a) Value)
-> Value -> Tagged (Maybe a) Value
forall a b. (a -> b) -> a -> b
$ Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList [ Tagged a Value -> Value
forall k (s :: k) b. Tagged s b -> b
untag Tagged a Value
model, Value
Null ]
gjsonModel :: forall a. (HasDatatypeInfo a, All2 JsonModel (Code a))
=> JsonOptions -> Tagged a Value
gjsonModel :: JsonOptions -> Tagged a Value
gjsonModel JsonOptions
opts = (Proxy a -> Value) -> Tagged a Value
forall k (s :: k) a. (Proxy s -> a) -> Tagged s a
unproxy ((Proxy a -> Value) -> Tagged a Value)
-> (Proxy a -> Value) -> Tagged a Value
forall a b. (a -> b) -> a -> b
$ \Proxy a
pa -> NP JsonInfo (Code a) -> Value
forall (xss :: [[*]]).
All2 JsonModel xss =>
NP JsonInfo xss -> Value
gjsonModel' (Proxy a -> JsonOptions -> NP JsonInfo (Code a)
forall a.
(HasDatatypeInfo a, SListI (Code a)) =>
Proxy a -> JsonOptions -> NP JsonInfo (Code a)
jsonInfo Proxy a
pa JsonOptions
opts)
gjsonModel' :: All2 JsonModel xss => NP JsonInfo xss -> Value
gjsonModel' :: NP JsonInfo xss -> Value
gjsonModel' = [Value] -> Value
mkValue ([Value] -> Value)
-> (NP JsonInfo xss -> [Value]) -> NP JsonInfo xss -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K Value) xss -> [Value]
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K Value) xss -> [Value])
-> (NP JsonInfo xss -> NP (K Value) xss)
-> NP JsonInfo xss
-> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (All JsonModel)
-> (forall (a :: [*]). All JsonModel a => JsonInfo a -> K Value a)
-> NP JsonInfo xss
-> NP (K Value) xss
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
(xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
(f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcliftA Proxy (All JsonModel)
allp (Value -> K Value a
forall k a (b :: k). a -> K a b
K (Value -> K Value a)
-> (JsonInfo a -> Value) -> JsonInfo a -> K Value a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonInfo a -> Value
forall (xs :: [*]). All JsonModel xs => JsonInfo xs -> Value
constructorModel)
where
mkValue :: [Value] -> Value
mkValue :: [Value] -> Value
mkValue [Value
v] = Value
v
mkValue [Value]
vs = Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList [Value]
vs
constructorModel :: forall xs. All JsonModel xs => JsonInfo xs -> Value
constructorModel :: JsonInfo xs -> Value
constructorModel (JsonZero String
n) =
[Pair] -> Value
object [ Key
"Literal" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON String
n ]
constructorModel info :: JsonInfo xs
info@(JsonOne Tag
t) = Tag -> Value -> Value
tagModel Tag
t (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$
JsonInfo '[a] -> Value
forall a. JsonModel a => JsonInfo '[a] -> Value
constructorModelOne JsonInfo xs
JsonInfo '[a]
info
constructorModel (JsonMultiple Tag
t) = Tag -> Value -> Value
tagModel Tag
t (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$
[Pair] -> Value
object [ Key
"Tuple" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ([Value] -> Value
tupleModel ([Value] -> Value)
-> (NP (K Value) xs -> [Value]) -> NP (K Value) xs -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K Value) xs -> [Value]
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K Value) xs -> Value) -> NP (K Value) xs -> Value
forall a b. (a -> b) -> a -> b
$ NP (K Value) xs
All JsonModel xs => NP (K Value) xs
aux) ]
where
aux :: All JsonModel xs => NP (K Value) xs
aux :: NP (K Value) xs
aux = Proxy JsonModel
-> (forall a. JsonModel a => K Value a) -> NP (K Value) xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
(xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *).
(HPure h, AllN h c xs) =>
proxy c -> (forall (a :: k). c a => f a) -> h f xs
hcpure Proxy JsonModel
p forall a. JsonModel a => K Value a
jsonModelK
constructorModel (JsonRecord Tag
t NP (K String) xs
fs) = Tag -> Value -> Value
tagModel Tag
t (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$
[Pair] -> Value
object [ Key
"Object" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ([(Text, Value)] -> Value
objectModel ([(Text, Value)] -> Value)
-> (NP (K String) xs -> [(Text, Value)])
-> NP (K String) xs
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K (Text, Value)) xs -> [(Text, Value)]
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K (Text, Value)) xs -> [(Text, Value)])
-> (NP (K String) xs -> NP (K (Text, Value)) xs)
-> NP (K String) xs
-> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy JsonModel
-> (forall a. JsonModel a => K String a -> K (Text, Value) a)
-> NP (K String) xs
-> NP (K (Text, Value)) xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
(xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
(f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcliftA Proxy JsonModel
p forall a. JsonModel a => K String a -> K (Text, Value) a
aux (NP (K String) xs -> Value) -> NP (K String) xs -> Value
forall a b. (a -> b) -> a -> b
$ NP (K String) xs
fs) ]
where
aux :: forall a. JsonModel a => K String a -> K (Text, Value) a
aux :: K String a -> K (Text, Value) a
aux (K String
f) = (Text, Value) -> K (Text, Value) a
forall k a (b :: k). a -> K a b
K (String -> Text
Text.pack String
f, Tagged a Value -> Value
forall k (s :: k) b. Tagged s b -> b
untag (Tagged a Value
forall a. JsonModel a => Tagged a Value
jsonModel :: Tagged a Value))
tupleModel :: [Value] -> Value
tupleModel :: [Value] -> Value
tupleModel = Array -> Value
Array (Array -> Value) -> ([Value] -> Array) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList
objectModel :: [(Text, Value)] -> Value
objectModel :: [(Text, Value)] -> Value
objectModel = Array -> Value
Array (Array -> Value)
-> ([(Text, Value)] -> Array) -> [(Text, Value)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList ([Value] -> Array)
-> ([(Text, Value)] -> [Value]) -> [(Text, Value)] -> Array
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Value) -> Value) -> [(Text, Value)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Value) -> Value
aux
where
aux :: (Text, Value) -> Value
aux :: (Text, Value) -> Value
aux (Text
name, Value
typ) = [Pair] -> Value
object [ Key
"name" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
name, Key
"type" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
typ ]
constructorModelOne :: forall a. JsonModel a => JsonInfo '[a] -> Value
constructorModelOne :: JsonInfo '[a] -> Value
constructorModelOne JsonInfo '[a]
_ = Tagged a Value -> Value
forall k (s :: k) b. Tagged s b -> b
untag (Tagged a Value
forall a. JsonModel a => Tagged a Value
jsonModel :: Tagged a Value)
jsonModelK :: forall a. JsonModel a => K Value a
jsonModelK :: K Value a
jsonModelK = Value -> K Value a
forall k a (b :: k). a -> K a b
K (Value -> K Value a) -> Value -> K Value a
forall a b. (a -> b) -> a -> b
$ Tagged a Value -> Value
forall k (s :: k) b. Tagged s b -> b
untag (Tagged a Value
forall a. JsonModel a => Tagged a Value
jsonModel :: Tagged a Value)
tagModel :: Tag -> Value -> Value
tagModel :: Tag -> Value -> Value
tagModel Tag
NoTag Value
v = Value
v
tagModel (Tag String
n) Value
v = [Pair] -> Value
object [ Key
"Object" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [ String -> Key
forall a. IsString a => String -> a
fromString String
n Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
v ] ]
p :: Proxy JsonModel
p :: Proxy JsonModel
p = Proxy JsonModel
forall k (t :: k). Proxy t
Proxy
allp :: Proxy (All JsonModel)
allp :: Proxy (All JsonModel)
allp = Proxy (All JsonModel)
forall k (t :: k). Proxy t
Proxy