module Generics.SOP.JSON.Model (
JsonModel(..)
, gjsonModel
, Tagged(..)
, untag
) where
import Data.Aeson
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 :: *) where
jsonModel :: Tagged a Value
instance JsonModel UTCTime where
jsonModel = Tagged $ String "UTCTime"
instance JsonModel Text where
jsonModel = Tagged $ String "String"
instance JsonModel Text.Lazy.Text where
jsonModel = Tagged $ String "String"
instance JsonModel String where
jsonModel = Tagged $ String "String"
instance JsonModel Int where
jsonModel = Tagged $ String "Int"
instance JsonModel Double where
jsonModel = Tagged $ String "Double"
instance JsonModel Rational where
jsonModel = Tagged $ String "Rational"
instance JsonModel Bool where
jsonModel = Tagged $ String "Bool"
instance JsonModel a => JsonModel [a] where
jsonModel = let model :: Tagged a Value
model = jsonModel
in Tagged $ object [ "List" .= untag model ]
instance JsonModel a => JsonModel (Maybe a) where
jsonModel = let model :: Tagged a Value
model = jsonModel
in Tagged $ Array $ Vector.fromList [ untag model, Null ]
gjsonModel :: forall a. (HasDatatypeInfo a, All2 JsonModel (Code a), SingI (Code a))
=> JsonOptions -> Tagged a Value
gjsonModel opts = unproxy $ \pa -> gjsonModel' (jsonInfo pa opts)
gjsonModel' :: (All2 JsonModel xss, SingI xss) => NP JsonInfo xss -> Value
gjsonModel' = mkValue . hcollapse . hcliftA' p (K . constructorModel)
where
mkValue :: [Value] -> Value
mkValue [v] = v
mkValue vs = Array $ Vector.fromList vs
constructorModel :: forall xs. All JsonModel xs => JsonInfo xs -> Value
constructorModel (JsonZero n) =
object [ "Literal" .= toJSON n ]
constructorModel info@(JsonOne t) = tagModel t $
constructorModelOne info
constructorModel (JsonMultiple t) = tagModel t $
object [ "Tuple" .= (tupleModel . hcollapse $ aux) ]
where
aux :: (SingI xs, All JsonModel xs) => NP (K Value) xs
aux = hcpure p jsonModelK
constructorModel (JsonRecord t fs) = tagModel t $
object [ "Object" .= (objectModel . hcollapse . hcliftA p aux $ fs) ]
where
aux :: forall a. JsonModel a => K String a -> K (Text, Value) a
aux (K f) = K (Text.pack f, untag (jsonModel :: Tagged a Value))
tupleModel :: [Value] -> Value
tupleModel = Array . Vector.fromList
objectModel :: [(Text, Value)] -> Value
objectModel = Array . Vector.fromList . map aux
where
aux :: (Text, Value) -> Value
aux (name, typ) = object [ "name" .= name, "type" .= typ ]
constructorModelOne :: forall a. JsonModel a => JsonInfo '[a] -> Value
constructorModelOne _ = untag (jsonModel :: Tagged a Value)
jsonModelK :: forall a. JsonModel a => K Value a
jsonModelK = K $ untag (jsonModel :: Tagged a Value)
tagModel :: Tag -> Value -> Value
tagModel NoTag v = v
tagModel (Tag n) v = object [ "Object" .= object [ Text.pack n .= v ] ]
p :: Proxy JsonModel
p = Proxy