{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-} {-# 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. 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. f a -> Parser (DSum f g)) -> Parser (DSum f g)) -> (forall a. 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. r a -> Value) -> Value forall k (tag :: k -> *) b. Some tag -> (forall (a :: k). tag a -> b) -> b withSome Some r some ((forall a. r a -> Value) -> Value) -> (forall a. 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)