{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PolyKinds #-} -- Necessary to allow DSums where the key and value range over types other than *
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.Dependent.Sum.Orphans where

import Data.Aeson
import Data.Constraint.Forall
import Data.Constraint.Extras
import Data.Dependent.Map (DMap)
import Data.GADT.Compare (GCompare)
import qualified Data.Dependent.Map as DMap
import Data.Dependent.Sum
import Data.Some (withSomeM, withSome, Some)

instance (ForallF ToJSON f, Has' ToJSON f g) => ToJSON (DSum f g) where
  toJSON :: DSum f g -> Value
toJSON ((f a
f :: f a) :=> (g a
g :: g a))
    = (ToJSON (f a) => Value) -> Value
forall k2 k1 (c :: k2 -> Constraint) (t :: k1 -> k2) (a :: k1) r.
ForallF c t =>
(c (t a) => r) -> r
whichever @ToJSON @f @a (f a -> (ToJSON (g a) => Value) -> Value
forall k k' (c :: k -> Constraint) (g :: k' -> k) (f :: k' -> *)
       (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @g f a
f ((f a, g a) -> Value
forall a. ToJSON a => a -> Value
toJSON (f a
f, g a
g)))

instance (ForallF ToJSON f, Has' ToJSON f g) => ToJSON (DMap f g) where
    toJSON :: DMap f g -> Value
toJSON = [DSum f g] -> Value
forall a. ToJSON a => a -> Value
toJSON ([DSum f g] -> Value)
-> (DMap f g -> [DSum f g]) -> DMap f g -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DMap f g -> [DSum f g]
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). DMap k2 f -> [DSum k2 f]
DMap.toList

instance (FromJSON (Some f), Has' FromJSON f g) => FromJSON (DSum f g) where
  parseJSON :: Value -> Parser (DSum f g)
parseJSON x :: Value
x = do
    (jf :: Value
jf, jg :: Value
jg) <- Value -> Parser (Value, Value)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
x
    Parser (Some f)
-> (forall (a :: k). f a -> Parser (DSum f g)) -> Parser (DSum f g)
forall k (m :: * -> *) (tag :: k -> *) r.
Monad m =>
m (Some tag) -> (forall (a :: k). tag a -> m r) -> m r
withSomeM (Value -> Parser (Some f)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
jf) ((forall (a :: k). f a -> Parser (DSum f g)) -> Parser (DSum f g))
-> (forall (a :: k). f a -> Parser (DSum f g)) -> Parser (DSum f g)
forall a b. (a -> b) -> a -> b
$ \(f :: f a) -> do
      g a
g <- f a -> (FromJSON (g a) => Parser (g a)) -> Parser (g a)
forall k k' (c :: k -> Constraint) (g :: k' -> k) (f :: k' -> *)
       (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @g f a
f (Value -> Parser (g a)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
jg)
      DSum f g -> Parser (DSum f g)
forall (m :: * -> *) a. Monad m => a -> m a
return (DSum f g -> Parser (DSum f g)) -> DSum f g -> Parser (DSum f g)
forall a b. (a -> b) -> a -> b
$ f a
f f a -> g a -> DSum f g
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> g a
g

instance (FromJSON (Some f), GCompare f, Has' FromJSON f g) => FromJSON (DMap f g) where
    parseJSON :: Value -> Parser (DMap f g)
parseJSON = ([DSum f g] -> DMap f g) -> Parser [DSum f g] -> Parser (DMap f g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [DSum f g] -> DMap f g
forall k1 (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
[DSum k2 f] -> DMap k2 f
DMap.fromList (Parser [DSum f g] -> Parser (DMap f g))
-> (Value -> Parser [DSum f g]) -> Value -> Parser (DMap f g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser [DSum f g]
forall a. FromJSON a => Value -> Parser a
parseJSON

instance (ForallF ToJSON r) => ToJSON (Some r) where
  toJSON :: Some r -> Value
toJSON some :: Some r
some = Some r -> (forall (a :: k). r a -> Value) -> Value
forall k (tag :: k -> *) b.
Some tag -> (forall (a :: k). tag a -> b) -> b
withSome Some r
some ((forall (a :: k). r a -> Value) -> Value)
-> (forall (a :: k). r a -> Value) -> Value
forall a b. (a -> b) -> a -> b
$ \(r a
x :: r a) -> (ToJSON (r a) => Value) -> Value
forall k2 k1 (c :: k2 -> Constraint) (t :: k1 -> k2) (a :: k1) r.
ForallF c t =>
(c (t a) => r) -> r
whichever @ToJSON @r @a (r a -> Value
forall a. ToJSON a => a -> Value
toJSON r a
x)