{-# 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 = 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 ]

{-------------------------------------------------------------------------------
  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 :: 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
    -- 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 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