{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

{-|
This module defines orphan `aeson` instances for `Data.Row`.
They differ from the instances in `row-types-aeson` in one crucial respect: they
serialise `Nothing` fields by *omitting* them in the resulting object, and parse absent fields as `Nothing`.
`aeson` can be configured to have this behviour for instances for datatypes, but we want to do this
for record types generically.

This is crucial to match what LSP clients expect.
-}
module Data.Row.Aeson where

import           Data.Aeson
import           Data.Aeson.Types      (Parser, typeMismatch)
import           Data.List             (intercalate)

import           Data.Row
import           Data.Row.Internal
import qualified Data.Row.Records      as Rec

import           Data.Bifunctor        (second)
import           Data.Functor.Const
import           Data.Functor.Identity
import           Data.Proxy
import           Data.String

-- `aeson` does not need such a typeclass because it generates code per-instance
-- that handles this, whereas we want to work generically.

-- | Serialise a value as an entry in a JSON object. This allows customizing the
-- behaviour in the object context, in order to e.g. omit the field.
class ToJSONEntry a where
  -- We use String so we can use fromString on it to get a key that works
  -- in both aeson-1 and aeson-2
  toJSONEntry :: String -> a -> Object

instance {-# OVERLAPPING #-} ToJSON a => ToJSONEntry (Maybe a) where
  -- Omit Nothing fields
  toJSONEntry :: String -> Maybe a -> Object
toJSONEntry String
_ Maybe a
Nothing = forall a. Monoid a => a
mempty
  toJSONEntry String
k Maybe a
v       = forall a. IsString a => String -> a
fromString String
k forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON Maybe a
v

instance {-# OVERLAPPABLE #-} ToJSON a => ToJSONEntry a where
  toJSONEntry :: String -> a -> Object
toJSONEntry String
k a
v = forall a. IsString a => String -> a
fromString String
k forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON a
v

class FromJSONEntry a where
  parseJSONEntry :: Object -> String -> Parser a

instance {-# OVERLAPPING #-} FromJSON a => FromJSONEntry (Maybe a) where
  -- Parse Nothing fields as optional
  parseJSONEntry :: Object -> String -> Parser (Maybe a)
parseJSONEntry Object
o String
k = Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? (forall a. IsString a => String -> a
fromString String
k)

instance {-# OVERLAPPABLE #-} FromJSON a => FromJSONEntry a where
  parseJSONEntry :: Object -> String -> Parser a
parseJSONEntry Object
o String
k = Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: (forall a. IsString a => String -> a
fromString String
k)

------

instance Forall r ToJSONEntry => ToJSON (Rec r) where
  -- Sadly, there appears to be no helper we can use that gives us access to the keys, so I just used metamorph directly
  -- adapted from 'eraseWithLabels'
  toJSON :: Rec r -> Value
toJSON Rec r
rc = Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall {k} a (b :: k). Const a b -> a
getConst forall a b. (a -> b) -> a -> b
$ forall k (r :: Row k) (c :: k -> Constraint) (p :: * -> * -> *)
       (f :: Row k -> *) (g :: Row k -> *) (h :: k -> *).
(Forall r c, Bifunctor p) =>
Proxy (Proxy h, Proxy p)
-> (f Empty -> g Empty)
-> (forall (ℓ :: Symbol) (τ :: k) (ρ :: Row k).
    (KnownSymbol ℓ, c τ, HasType ℓ τ ρ) =>
    Label ℓ -> f ρ -> p (f (ρ .- ℓ)) (h τ))
-> (forall (ℓ :: Symbol) (τ :: k) (ρ :: Row k).
    (KnownSymbol ℓ, c τ, FrontExtends ℓ τ ρ,
     AllUniqueLabels (Extend ℓ τ ρ)) =>
    Label ℓ -> p (g ρ) (h τ) -> g (Extend ℓ τ ρ))
-> f r
-> g r
metamorph @_ @r @ToJSONEntry @(,) @Rec @(Const Object) @Identity forall {k} (t :: k). Proxy t
Proxy forall {a}. Rec Empty -> Const Object Empty
doNil forall (l :: Symbol) (r' :: Row (*)).
KnownSymbol l =>
Label l -> Rec r' -> (Rec (r' .- l), Identity (r' .! l))
doUncons forall (l :: Symbol) t (r' :: Row (*)).
(KnownSymbol l, ToJSONEntry t) =>
Label l
-> (Const Object r', Identity t) -> Const Object (Extend l t r')
doCons Rec r
rc
      where
        doNil :: Rec Empty -> Const Object Empty
        doNil :: forall {a}. Rec Empty -> Const Object Empty
doNil Rec Empty
_ = forall {k} a (b :: k). a -> Const a b
Const forall a. Monoid a => a
mempty
        doUncons
          :: forall l r'
          . (KnownSymbol l)
          => Label l
          -> Rec r'
          -> (Rec (r' .- l), Identity (r' .! l))
        doUncons :: forall (l :: Symbol) (r' :: Row (*)).
KnownSymbol l =>
Label l -> Rec r' -> (Rec (r' .- l), Identity (r' .! l))
doUncons Label l
l = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: Symbol) (r :: Row (*)).
KnownSymbol l =>
Label l -> Rec r -> (Rec (r .- l), r .! l)
lazyUncons Label l
l
        doCons
          :: forall l t r'
          . (KnownSymbol l, ToJSONEntry t)
          => Label l
          -> (Const Object r', Identity t)
          -> Const Object (Extend l t r')
        doCons :: forall (l :: Symbol) t (r' :: Row (*)).
(KnownSymbol l, ToJSONEntry t) =>
Label l
-> (Const Object r', Identity t) -> Const Object (Extend l t r')
doCons Label l
l (Const Object
c, Identity t
x) = forall {k} a (b :: k). a -> Const a b
Const forall a b. (a -> b) -> a -> b
$ forall a. ToJSONEntry a => String -> a -> Object
toJSONEntry (forall s a. (IsString s, Show a) => a -> s
show' Label l
l) t
x forall a. Semigroup a => a -> a -> a
<> Object
c

instance (AllUniqueLabels r, Forall r FromJSONEntry) => FromJSON (Rec r) where
  parseJSON :: Value -> Parser (Rec r)
parseJSON (Object Object
o) = do
    Rec r
r <- forall (c :: * -> Constraint) (f :: * -> *) (ρ :: Row (*)).
(Applicative f, Forall ρ c, AllUniqueLabels ρ) =>
(forall (l :: Symbol) a. (KnownSymbol l, c a) => Label l -> f a)
-> f (Rec ρ)
Rec.fromLabelsA @FromJSONEntry forall a b. (a -> b) -> a -> b
$ \ Label l
l -> do
      a
x <- forall a. FromJSONEntry a => Object -> String -> Parser a
parseJSONEntry Object
o (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Label l
l)
      a
x seq :: forall a b. a -> b -> b
`seq` forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    Rec r
r seq :: forall a b. a -> b -> b
`seq` forall (f :: * -> *) a. Applicative f => a -> f a
pure Rec r
r

  parseJSON Value
v = forall a. String -> Value -> Parser a
typeMismatch String
msg Value
v
    where msg :: String
msg = String
"REC: {" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall {k} (ρ :: Row k) (c :: k -> Constraint) s.
(IsString s, Forall ρ c) =>
[s]
labels @r @FromJSONEntry) forall a. [a] -> [a] -> [a]
++ String
"}"

--- Copied from the library, as it's private

lazyUncons :: KnownSymbol l => Label l -> Rec r -> (Rec (r .- l), r .! l)
lazyUncons :: forall (l :: Symbol) (r :: Row (*)).
KnownSymbol l =>
Label l -> Rec r -> (Rec (r .- l), r .! l)
lazyUncons Label l
l Rec r
r = (forall (l :: Symbol) (r :: Row (*)).
KnownSymbol l =>
Label l -> Rec r -> Rec (r .- l)
Rec.lazyRemove Label l
l Rec r
r, Rec r
r forall (l :: Symbol) (r :: Row (*)).
KnownSymbol l =>
Rec r -> Label l -> r .! l
.! Label l
l)