{-# LANGUAGE OverloadedStrings #-}

module Generics.SOP.JSON.Model (
    JsonModel(..)
  , gjsonModel
    -- * Re-exports
  , 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

-- For instances only
import Data.Time (UTCTime)
import Data.Text (Text)

class JsonModel (a :: Type) where
  jsonModel :: Tagged a Value

{-------------------------------------------------------------------------------
  Some standard instances
-------------------------------------------------------------------------------}

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 ]

{-------------------------------------------------------------------------------
  Generic instance
-------------------------------------------------------------------------------}

-- | Generic computation of the JSON model
--
-- Do NOT use for recursive types, you will get an infinite model.
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
    -- In the case of a single-argument datatype, just return the type of
    -- the constructor, rather than a singleton list of types
    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