{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
module Data.ComposableAssociation.Aeson
    ( -- * Quickstart
      -- $quickstart

      -- * Re-Exported Core Types\/Functions\/Lens
      module Data.ComposableAssociation

      -- * Invalid JSON Encoding Exception
    , JsonObjectEncodingException (..)
    ) where


import GHC.TypeLits
import Data.Proxy
import Data.Typeable
import Control.Exception

import qualified Data.Text as T
import Data.Aeson
import Data.Aeson.Types
import qualified Data.HashMap.Lazy as HashMap

import Data.ComposableAssociation


-- | More specific version of @ObjectEncodingException@ to only Aeson encoding issues.
newtype JsonObjectEncodingException = JsonObjectEncodingException Value deriving (Int -> JsonObjectEncodingException -> ShowS
[JsonObjectEncodingException] -> ShowS
JsonObjectEncodingException -> String
(Int -> JsonObjectEncodingException -> ShowS)
-> (JsonObjectEncodingException -> String)
-> ([JsonObjectEncodingException] -> ShowS)
-> Show JsonObjectEncodingException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JsonObjectEncodingException] -> ShowS
$cshowList :: [JsonObjectEncodingException] -> ShowS
show :: JsonObjectEncodingException -> String
$cshow :: JsonObjectEncodingException -> String
showsPrec :: Int -> JsonObjectEncodingException -> ShowS
$cshowsPrec :: Int -> JsonObjectEncodingException -> ShowS
Show, Typeable)
instance Exception JsonObjectEncodingException where
  toException :: JsonObjectEncodingException -> SomeException
toException = ObjectEncodingException -> SomeException
forall e. Exception e => e -> SomeException
toException (ObjectEncodingException -> SomeException)
-> (JsonObjectEncodingException -> ObjectEncodingException)
-> JsonObjectEncodingException
-> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonObjectEncodingException -> ObjectEncodingException
forall e. Exception e => e -> ObjectEncodingException
ObjectEncodingException
  fromException :: SomeException -> Maybe JsonObjectEncodingException
fromException SomeException
x = do
    ObjectEncodingException e
e <- SomeException -> Maybe ObjectEncodingException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x
    e -> Maybe JsonObjectEncodingException
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e



instance (ToJSON obj, KnownSymbol key) => ToJSON (Association key obj) where
  toJSON :: Association key obj -> Value
toJSON (Association Proxy key
key obj
obj) = [Pair] -> Value
object [Text
keyName Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= obj -> Value
forall a. ToJSON a => a -> Value
toJSON obj
obj]
    where keyName :: Text
keyName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy key -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy key
key

instance (FromJSON obj, KnownSymbol key) => FromJSON (Association key obj) where
  parseJSON :: Value -> Parser (Association key obj)
parseJSON = String
-> (Object -> Parser (Association key obj))
-> Value
-> Parser (Association key obj)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Association" ((Object -> Parser (Association key obj))
 -> Value -> Parser (Association key obj))
-> (Object -> Parser (Association key obj))
-> Value
-> Parser (Association key obj)
forall a b. (a -> b) -> a -> b
$ \Object
v' -> Proxy key -> obj -> Association key obj
forall k (key :: k) value.
Proxy key -> value -> Association key value
Association Proxy key
proxy (obj -> Association key obj)
-> Parser obj -> Parser (Association key obj)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v' Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
key Parser (Maybe Value) -> Value -> Parser Value
forall a. Parser (Maybe a) -> a -> Parser a
.!= Value
Null Parser Value -> (Value -> Parser obj) -> Parser obj
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser obj
forall a. FromJSON a => Value -> Parser a
parseJSON)
      where proxy :: Proxy key
proxy = Proxy key
forall k (t :: k). Proxy t
Proxy :: Proxy key
            key :: Text
key = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy key -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy key
proxy


-- | Throws a @JsonObjectEncodingException@ if the base value isn't encoded as a JSON object
instance (ToJSON base, ToJSON obj, KnownSymbol key) => ToJSON (base :<> Association key obj) where
  toJSON :: (base :<> Association key obj) -> Value
toJSON (base
base :<> Association Proxy key
key obj
obj) = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Text
keyName Value
objJson Object
baseJsonMap
    where keyName :: Text
keyName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy key -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy key
key
          baseJsonMap :: Object
baseJsonMap = case base -> Value
forall a. ToJSON a => a -> Value
toJSON base
base of (Object Object
jsonObjVal) -> Object
jsonObjVal
                                            Value
notAnObject -> JsonObjectEncodingException -> Object
forall a e. Exception e => e -> a
throw (JsonObjectEncodingException -> Object)
-> JsonObjectEncodingException -> Object
forall a b. (a -> b) -> a -> b
$ Value -> JsonObjectEncodingException
JsonObjectEncodingException Value
notAnObject
          objJson :: Value
objJson = obj -> Value
forall a. ToJSON a => a -> Value
toJSON obj
obj

instance (FromJSON base, FromJSON obj, KnownSymbol key) => FromJSON (base :<> Association key obj) where
  parseJSON :: Value -> Parser (base :<> Association key obj)
parseJSON = String
-> (Object -> Parser (base :<> Association key obj))
-> Value
-> Parser (base :<> Association key obj)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"base :<> assoc" ((Object -> Parser (base :<> Association key obj))
 -> Value -> Parser (base :<> Association key obj))
-> (Object -> Parser (base :<> Association key obj))
-> Value
-> Parser (base :<> Association key obj)
forall a b. (a -> b) -> a -> b
$ \Object
v' -> base -> Association key obj -> base :<> Association key obj
forall base assoc. base -> assoc -> base :<> assoc
(:<>) (base -> Association key obj -> base :<> Association key obj)
-> Parser base
-> Parser (Association key obj -> base :<> Association key obj)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                            Value -> Parser base
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete Text
key Object
v') Parser (Association key obj -> base :<> Association key obj)
-> Parser (Association key obj)
-> Parser (base :<> Association key obj)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                            (obj -> Association key obj)
-> Parser obj -> Parser (Association key obj)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proxy key -> obj -> Association key obj
forall k (key :: k) value.
Proxy key -> value -> Association key value
Association Proxy key
proxy) (Object
v' Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
key Parser (Maybe Value) -> Value -> Parser Value
forall a. Parser (Maybe a) -> a -> Parser a
.!= Value
Null Parser Value -> (Value -> Parser obj) -> Parser obj
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser obj
forall a. FromJSON a => Value -> Parser a
parseJSON)
    where proxy :: Proxy key
proxy = Proxy key
forall k (t :: k). Proxy t
Proxy :: Proxy key
          key :: Text
key = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy key -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy key
proxy

-- $setup
-- >>> import GHC.Generics

-- $quickstart
-- Assume some example data below:
--
-- >>> data ExampleUser = ExampleUser { name :: String, age :: Int } deriving (Show, Eq, Generic)
-- >>> instance ToJSON ExampleUser
-- >>> instance FromJSON ExampleUser
-- >>> data ExampleUserWithMessages = ExampleUserWithMessages { name :: String, age :: Int, messages :: [Int] } deriving (Show, Eq, Generic)
-- >>> instance ToJSON ExampleUserWithMessages
-- >>> instance FromJSON ExampleUserWithMessages
--
-- >>> let aliceName = "Alice"
-- >>> let aliceAge = 25
-- >>> let messageIds = [102, 305, 410]
-- >>> let alice = ExampleUser aliceName aliceAge
-- >>> let aliceWithMessages = ExampleUserWithMessages aliceName aliceAge messageIds
--
--
-- Let's add those messages to the alice object without requiring our custom "WithMessages" version of the User type.
--
-- >>> let adHocAliceWithMessages = alice :<> (asValue messageIds :: Association "messages" [Int])
-- >>> encode aliceWithMessages == encode adHocAliceWithMessages
-- True
--
-- Since "messages" is type (not value) information, we can decode as well.
--
-- >>> decode "{\"age\":25,\"name\":\"Alice\",\"messages\":[102,305,410]}" :: Maybe (ExampleUser :<> Association "messages" [Int])
-- Just (ExampleUser {name = "Alice", age = 25} :<> Association Proxy [102,305,410])
--
-- In the above, "Proxy" is the value of type "messages".
--
-- @Association Proxy a@ has a stand-alone encoding/decoding too
--
-- >>> encode $ Association (Proxy :: Proxy "one-off-key") [1, 2, 3]
-- "{\"one-off-key\":[1,2,3]}"
--
-- >>> decode "{\"one-off-key\":[1,2,3]}" :: Maybe (Association "one-off-key" [Int])
-- Just (Association Proxy [1,2,3])
--
-- You can build JSON objects from just values!
--
-- >>> :{
-- let allValues :: Association "name" String :<> Association "age" Int
--     allValues = asValue aliceName :<> asValue aliceAge
-- in encode allValues == encode alice
-- :}
-- True
--
-- Decoding fails if you specify a non-existent key (standard Aeson behavior for failed decoding).
--
-- >>> decode "{\"one-off-key\":[1,2,3]}" :: Maybe (Association "wrong-key" [Int])
-- Nothing
--
-- If you try encoding with a "base" value that is itself not encoded to a JSON object you'll get a runtime exception.
--
-- >>> encode $ True :<> (asValue [1,2,3] :: Association "this-ends-poorly" [Int])
-- "*** Exception: JsonObjectEncodingException (Bool True)
--
-- GHC Extension Note:
--
-- * You'll need @DataKinds@ for this library (type level literals, no getting around this).
--
-- * You'll probably want @TypeOperators@ as well (although you can use @WithAssociation@ instead of @:<>@ to avoid this).
--
-- * You can avoid @PolyKinds@ if you use @asValue True :: Association "key" Bool@ or type inference instead of
-- @Association (Proxy :: Proxy "key") True@.