{-# 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 Data.Row.Records qualified as Rec

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

import Language.LSP.Protocol.Types.Common ((.:!?))

-- `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 = Object
forall a. Monoid a => a
mempty
  toJSONEntry String
k Maybe a
v = String -> Key
forall a. IsString a => String -> a
fromString String
k Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe a -> Value
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 = String -> Key
forall a. IsString a => String -> a
fromString String
k Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= a -> Value
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, accepting Null to mean "missing"
  parseJSONEntry :: Object -> String -> Parser (Maybe a)
parseJSONEntry Object
o String
k = Object
o Object -> Key -> Parser (Maybe a)
forall v. FromJSON v => Object -> Key -> Parser (Maybe v)
.:!? (String -> Key
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 Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: (String -> Key
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 (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Const Object r -> Object
forall {k} a (b :: k). Const a b -> a
getConst (Const Object r -> Object) -> Const Object r -> Object
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 Proxy (Proxy Identity, Proxy (,))
forall {k} (t :: k). Proxy t
Proxy Rec Empty -> Const Object Empty
forall {a}. Rec Empty -> Const Object Empty
doNil Label ℓ -> Rec ρ -> (Rec (ρ .- ℓ), Identity τ)
Label ℓ -> Rec ρ -> (Rec (ρ .- ℓ), Identity (ρ .! ℓ))
forall (ℓ :: Symbol) τ (ρ :: Row (*)).
(KnownSymbol ℓ, ToJSONEntry τ, HasType ℓ τ ρ) =>
Label ℓ -> Rec ρ -> (Rec (ρ .- ℓ), Identity τ)
forall (l :: Symbol) (r' :: Row (*)).
KnownSymbol l =>
Label l -> Rec r' -> (Rec (r' .- l), Identity (r' .! l))
doUncons Label ℓ
-> (Const Object ρ, Identity τ) -> Const Object (Extend ℓ τ ρ)
forall (ℓ :: Symbol) τ (ρ :: Row (*)).
(KnownSymbol ℓ, ToJSONEntry τ, FrontExtends ℓ τ ρ,
 AllUniqueLabels (Extend ℓ τ ρ)) =>
Label ℓ
-> (Const Object ρ, Identity τ) -> Const Object (Extend ℓ τ ρ)
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
_ = Object -> Const Object Empty
forall {k} a (b :: k). a -> Const a b
Const Object
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 = ((r' .! l) -> Identity (r' .! l))
-> (Rec (r' .- l), r' .! l) -> (Rec (r' .- l), Identity (r' .! l))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (r' .! l) -> Identity (r' .! l)
forall a. a -> Identity a
Identity ((Rec (r' .- l), r' .! l) -> (Rec (r' .- l), Identity (r' .! l)))
-> (Rec r' -> (Rec (r' .- l), r' .! l))
-> Rec r'
-> (Rec (r' .- l), Identity (r' .! l))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label l -> Rec r' -> (Rec (r' .- l), r' .! l)
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) = Object -> Const Object (Extend l t r')
forall {k} a (b :: k). a -> Const a b
Const (Object -> Const Object (Extend l t r'))
-> Object -> Const Object (Extend l t r')
forall a b. (a -> b) -> a -> b
$ String -> t -> Object
forall a. ToJSONEntry a => String -> a -> Object
toJSONEntry (Label l -> String
forall s a. (IsString s, Show a) => a -> s
show' Label l
l) t
x Object -> Object -> Object
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 (l :: Symbol) a.
  (KnownSymbol l, FromJSONEntry a) =>
  Label l -> Parser a)
 -> Parser (Rec r))
-> (forall (l :: Symbol) a.
    (KnownSymbol l, FromJSONEntry a) =>
    Label l -> Parser a)
-> Parser (Rec r)
forall a b. (a -> b) -> a -> b
$ \Label l
l -> do
      a
x <- Object -> String -> Parser a
forall a. FromJSONEntry a => Object -> String -> Parser a
parseJSONEntry Object
o (String -> String
forall a. IsString a => String -> a
fromString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Label l -> String
forall a. Show a => a -> String
show Label l
l)
      a
x a -> Parser a -> Parser a
forall a b. a -> b -> b
`seq` a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    Rec r
r Rec r -> Parser (Rec r) -> Parser (Rec r)
forall a b. a -> b -> b
`seq` Rec r -> Parser (Rec r)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rec r
r
  parseJSON Value
v = String -> Value -> Parser (Rec r)
forall a. String -> Value -> Parser a
typeMismatch String
msg Value
v
   where
    msg :: String
msg = String
"REC: {" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall {k} (ρ :: Row k) (c :: k -> Constraint) s.
(IsString s, Forall ρ c) =>
[s]
forall (ρ :: Row (*)) (c :: * -> Constraint) s.
(IsString s, Forall ρ c) =>
[s]
labels @r @FromJSONEntry) String -> String -> String
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 = (Label l -> Rec r -> Rec (r .- l)
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 Rec r -> Label l -> r .! l
forall (l :: Symbol) (r :: Row (*)).
KnownSymbol l =>
Rec r -> Label l -> r .! l
.! Label l
l)