{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- |
-- Module        : Data.Sum.Pure.Aeson
-- Copyright     : Gautier DI FOLCO
-- License       : BSD2
--
-- Maintainer    : Gautier DI FOLCO <gautier.difolco@gmail.com>
-- Stability     : Unstable
-- Portability   : GHC
--
-- Derive fromText/toText-like for pure sum types (aeson instances).
module Data.Sum.Pure.Aeson
  ( -- * Base type
    FromJSON (..),
    FromJSONKey (..),
    ToJSON (..),
    ToJSONKey (..),

    -- * Reexport
    module X,
  )
where

import Data.Aeson.Types
import Data.Proxy
import Data.Sum.Pure as X
import qualified Data.Text as T
import GHC.Generics
import GHC.TypeLits

-- -- * Base interface
--
-- -- | Wrapper for derivation.
-- -- @transformation@ is a @Transformation@ applied during derivations
-- newtype PureSumWith transformation a = PureSumWith {unPureSumWith :: a}
--   deriving stock (Eq, Ord, Show)
--
-- -- | Basic sum derivation
-- type PureSum = PureSumWith IdTransformation
--
-- class ToSumText a where
--   toSumText :: a -> T.Text
--
-- class FromSumText a where
--   fromSumText :: T.Text -> Maybe a

instance (FromSumText a, Generic a, GConstructorName (Rep a)) => FromJSON (PureSumWith transformation a) where
  parseJSON :: Value -> Parser (PureSumWith transformation a)
parseJSON = String
-> (Text -> Parser (PureSumWith transformation a))
-> Value
-> Parser (PureSumWith transformation a)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText (ConstructorName a -> String
forall x. ConstructorName x -> String
unConstructionName (ConstructorName a -> String) -> ConstructorName a -> String
forall a b. (a -> b) -> a -> b
$ (forall a x. Generic a => Rep a x -> a
to @a) (Rep a Any -> a)
-> ConstructorName (Rep a Any) -> ConstructorName a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorName (Rep a Any)
forall a. ConstructorName (Rep a a)
forall (f :: * -> *) a. GConstructorName f => ConstructorName (f a)
gConstructorName) Text -> Parser (PureSumWith transformation a)
forall a transformation.
FromSumText a =>
Text -> Parser (PureSumWith transformation a)
pureSumWithParser

instance (FromSumText a, Generic a, GConstructorName (Rep a)) => FromJSONKey (PureSumWith transformation a) where
  fromJSONKey :: FromJSONKeyFunction (PureSumWith transformation a)
fromJSONKey = (Text -> Parser (PureSumWith transformation a))
-> FromJSONKeyFunction (PureSumWith transformation a)
forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser Text -> Parser (PureSumWith transformation a)
forall a transformation.
FromSumText a =>
Text -> Parser (PureSumWith transformation a)
pureSumWithParser

pureSumWithParser :: (FromSumText a) => T.Text -> Parser (PureSumWith transformation a)
pureSumWithParser :: forall a transformation.
FromSumText a =>
Text -> Parser (PureSumWith transformation a)
pureSumWithParser Text
x =
  Parser (PureSumWith transformation a)
-> (a -> Parser (PureSumWith transformation a))
-> Maybe a
-> Parser (PureSumWith transformation a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser (PureSumWith transformation a)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (PureSumWith transformation a))
-> String -> Parser (PureSumWith transformation a)
forall a b. (a -> b) -> a -> b
$ String
"unknown value: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
x) (PureSumWith transformation a
-> Parser (PureSumWith transformation a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PureSumWith transformation a
 -> Parser (PureSumWith transformation a))
-> (a -> PureSumWith transformation a)
-> a
-> Parser (PureSumWith transformation a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> PureSumWith transformation a
forall transformation a. a -> PureSumWith transformation a
PureSumWith) (Maybe a -> Parser (PureSumWith transformation a))
-> Maybe a -> Parser (PureSumWith transformation a)
forall a b. (a -> b) -> a -> b
$
    Text -> Maybe a
forall a. FromSumText a => Text -> Maybe a
fromSumText Text
x

newtype ConstructorName x = ConstructorName {forall x. ConstructorName x -> String
unConstructionName :: String}

instance Functor ConstructorName where
  fmap :: forall a b. (a -> b) -> ConstructorName a -> ConstructorName b
fmap a -> b
_ (ConstructorName String
x) = String -> ConstructorName b
forall x. String -> ConstructorName x
ConstructorName String
x

class GConstructorName f where
  gConstructorName :: ConstructorName (f a)

instance (KnownSymbol typeName) => GConstructorName (M1 D ('MetaData typeName c i b) a) where -- base type
  gConstructorName :: forall a. ConstructorName (M1 D ('MetaData typeName c i b) a a)
gConstructorName = String -> ConstructorName (M1 D ('MetaData typeName c i b) a a)
forall x. String -> ConstructorName x
ConstructorName (String -> ConstructorName (M1 D ('MetaData typeName c i b) a a))
-> String -> ConstructorName (M1 D ('MetaData typeName c i b) a a)
forall a b. (a -> b) -> a -> b
$ Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @typeName)

instance (ToSumText a) => ToJSON (PureSumWith transformation a) where
  toJSON :: PureSumWith transformation a -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value)
-> (PureSumWith transformation a -> Text)
-> PureSumWith transformation a
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. ToSumText a => a -> Text
toSumText (a -> Text)
-> (PureSumWith transformation a -> a)
-> PureSumWith transformation a
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PureSumWith transformation a -> a
forall transformation a. PureSumWith transformation a -> a
unPureSumWith
  toEncoding :: PureSumWith transformation a -> Encoding
toEncoding = Text -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Text -> Encoding)
-> (PureSumWith transformation a -> Text)
-> PureSumWith transformation a
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. ToSumText a => a -> Text
toSumText (a -> Text)
-> (PureSumWith transformation a -> a)
-> PureSumWith transformation a
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PureSumWith transformation a -> a
forall transformation a. PureSumWith transformation a -> a
unPureSumWith

instance (ToSumText a) => ToJSONKey (PureSumWith transformation a) where
  toJSONKey :: ToJSONKeyFunction (PureSumWith transformation a)
toJSONKey = (PureSumWith transformation a -> Text)
-> ToJSONKeyFunction (PureSumWith transformation a)
forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText (a -> Text
forall a. ToSumText a => a -> Text
toSumText (a -> Text)
-> (PureSumWith transformation a -> a)
-> PureSumWith transformation a
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PureSumWith transformation a -> a
forall transformation a. PureSumWith transformation a -> a
unPureSumWith)