{-# 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 = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"UTCTime"
instance JsonModel Text where
jsonModel :: Tagged Text Value
jsonModel = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"String"
instance JsonModel Text.Lazy.Text where
jsonModel :: Tagged Text Value
jsonModel = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"String"
instance {-# OVERLAPPING #-} JsonModel String where
jsonModel :: Tagged String Value
jsonModel = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"String"
instance JsonModel Int where
jsonModel :: Tagged Int Value
jsonModel = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"Int"
instance JsonModel Double where
jsonModel :: Tagged Double Value
jsonModel = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"Double"
instance JsonModel Rational where
jsonModel :: Tagged Rational Value
jsonModel = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"Rational"
instance JsonModel Bool where
jsonModel :: Tagged Bool Value
jsonModel = forall {k} (s :: k) b. b -> Tagged s b
Tagged 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 = forall a. JsonModel a => Tagged a Value
jsonModel
in forall {k} (s :: k) b. b -> Tagged s b
Tagged forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Key
"List" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= 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 = forall a. JsonModel a => Tagged a Value
jsonModel
in forall {k} (s :: k) b. b -> Tagged s b
Tagged forall a b. (a -> b) -> a -> b
$ Array -> Value
Array forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
Vector.fromList [ 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 :: forall a.
(HasDatatypeInfo a, All2 JsonModel (Code a)) =>
JsonOptions -> Tagged a Value
gjsonModel JsonOptions
opts = forall {k} (s :: k) a. (Proxy s -> a) -> Tagged s a
unproxy forall a b. (a -> b) -> a -> b
$ \Proxy a
pa -> forall (xss :: [[*]]).
All2 JsonModel xss =>
NP JsonInfo xss -> Value
gjsonModel' (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' :: forall (xss :: [[*]]).
All2 JsonModel xss =>
NP JsonInfo xss -> Value
gjsonModel' = [Value] -> Value
mkValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (forall k a (b :: k). a -> K a b
K forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
Vector.fromList [Value]
vs
constructorModel :: forall xs. All JsonModel xs => JsonInfo xs -> Value
constructorModel :: forall (xs :: [*]). All JsonModel xs => JsonInfo xs -> Value
constructorModel (JsonZero String
n) =
[Pair] -> Value
object [ Key
"Literal" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON String
n ]
constructorModel info :: JsonInfo xs
info@(JsonOne Tag
t) = Tag -> Value -> Value
tagModel Tag
t forall a b. (a -> b) -> a -> b
$
forall a. JsonModel a => JsonInfo '[a] -> Value
constructorModelOne JsonInfo xs
info
constructorModel (JsonMultiple Tag
t) = Tag -> Value -> Value
tagModel Tag
t forall a b. (a -> b) -> a -> b
$
[Pair] -> Value
object [ Key
"Tuple" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ([Value] -> Value
tupleModel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$ All JsonModel xs => NP (K Value) xs
aux) ]
where
aux :: All JsonModel xs => NP (K Value) xs
aux :: All JsonModel xs => NP (K Value) xs
aux = 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 forall a b. (a -> b) -> a -> b
$
[Pair] -> Value
object [ Key
"Object" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ([(Text, Value)] -> Value
objectModel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 :: forall a. JsonModel a => K String a -> K (Text, Value) a
aux (K String
f) = forall k a (b :: k). a -> K a b
K (String -> Text
Text.pack String
f, forall {k} (s :: k) b. Tagged s b -> b
untag (forall a. JsonModel a => Tagged a Value
jsonModel :: Tagged a Value))
tupleModel :: [Value] -> Value
tupleModel :: [Value] -> Value
tupleModel = Array -> Value
Array forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
Vector.fromList
objectModel :: [(Text, Value)] -> Value
objectModel :: [(Text, Value)] -> Value
objectModel = Array -> Value
Array forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
Vector.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
name, Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
typ ]
constructorModelOne :: forall a. JsonModel a => JsonInfo '[a] -> Value
constructorModelOne :: forall a. JsonModel a => JsonInfo '[a] -> Value
constructorModelOne JsonInfo '[a]
_ = forall {k} (s :: k) b. Tagged s b -> b
untag (forall a. JsonModel a => Tagged a Value
jsonModel :: Tagged a Value)
jsonModelK :: forall a. JsonModel a => K Value a
jsonModelK :: forall a. JsonModel a => K Value a
jsonModelK = forall k a (b :: k). a -> K a b
K forall a b. (a -> b) -> a -> b
$ forall {k} (s :: k) b. Tagged s b -> b
untag (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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [ forall a. IsString a => String -> a
fromString String
n forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
v ] ]
p :: Proxy JsonModel
p :: Proxy JsonModel
p = forall {k} (t :: k). Proxy t
Proxy
allp :: Proxy (All JsonModel)
allp :: Proxy (All JsonModel)
allp = forall {k} (t :: k). Proxy t
Proxy