{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language MultiParamTypeClasses #-}
{-# language PartialTypeSignatures #-}
{-# language PolyKinds #-}
{-# language QuantifiedConstraints #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
module Generics.Kind.Derive.Json where
import Control.Applicative
import Control.Monad
import Data.Aeson
import Data.Aeson.Types
import Data.Kind
import Data.Proxy
import GHC.Generics (Meta (..))
import GHC.TypeLits
import Generics.Kind
gtoJSON' :: forall t. (GenericK t, GToJSONK (RepK t) 'LoT0)
=> t -> Value
gtoJSON' x = gtoJSON (fromK @_ @t @'LoT0 x)
gfromJSON' :: forall t. (GenericK t, GFromJSONK (RepK t) 'LoT0)
=> Value -> Parser t
gfromJSON' v = fmap (toK @_ @t @'LoT0) (gfromJSON v)
class GToJSONK (f :: LoT k -> Type) (x :: LoT k) where
gtoJSON :: f x -> Value
class GFromJSONK (f :: LoT k -> Type) (x :: LoT k) where
gfromJSON :: Value -> Parser (f x)
instance ToJSON (Interpret t x)
=> GToJSONK (Field t) x where
gtoJSON (Field t) = toJSON t
instance FromJSON (Interpret t x)
=> GFromJSONK (Field t) x where
gfromJSON = fmap Field . parseJSON
instance GToJSONK U1 x where
gtoJSON U1 = Null
instance GFromJSONK U1 x where
gfromJSON Null = pure U1
gfromJSON _ = empty
instance (GToJSONK f x, GToJSONK g x)
=> GToJSONK (f :+: g) x where
gtoJSON (L1 f) = gtoJSON f
gtoJSON (R1 g) = gtoJSON g
instance (GFromJSONK f x, GFromJSONK g x)
=> GFromJSONK (f :+: g) x where
gfromJSON v = (L1 <$> gfromJSON v) <|> (R1 <$> gfromJSON v)
instance (GToJSONK f x, GToJSONK g x)
=> GToJSONK (f :*: g) x where
gtoJSON (f :*: g) = toJSON (gtoJSON f, gtoJSON g)
instance (GFromJSONK f x, GFromJSONK g x)
=> GFromJSONK (f :*: g) x where
gfromJSON v = do (f, g) <- parseJSON v
(:*:) <$> gfromJSON f <*> gfromJSON g
instance forall name f x i fx st.
(GToJSONK f x, KnownSymbol name)
=> GToJSONK (M1 i ('MetaCons name fx st) f) x where
gtoJSON (M1 f) = toJSON (symbolVal $ Proxy @name, gtoJSON f)
instance forall name f x i fx st.
(GFromJSONK f x, KnownSymbol name)
=> GFromJSONK (M1 i ('MetaCons name fx st) f) x where
gfromJSON v = do (name, f) <- parseJSON v
guard $ name == symbolVal (Proxy @name)
M1 <$> gfromJSON f
instance GToJSONK f x
=> GToJSONK (M1 i ('MetaData _1 _2 _3 _4) f) x where
gtoJSON (M1 f) = gtoJSON f
instance GFromJSONK f x
=> GFromJSONK (M1 i ('MetaData _1 _2 _3 _4) f) x where
gfromJSON = fmap M1 . gfromJSON
instance GToJSONK f x
=> GToJSONK (M1 i ('MetaSel _1 _2 _3 _4) f) x where
gtoJSON (M1 f) = gtoJSON f
instance GFromJSONK f x
=> GFromJSONK (M1 i ('MetaSel _1 _2 _3 _4) f) x where
gfromJSON = fmap M1 . gfromJSON
instance (Interpret c x => GToJSONK f x)
=> GToJSONK (c :=>: f) x where
gtoJSON (SuchThat f) = gtoJSON f
instance (Interpret c x, GFromJSONK f x)
=> GFromJSONK (c :=>: f) x where
gfromJSON = fmap SuchThat . gfromJSON
instance (forall t. GToJSONK f (t ':&&: x))
=> GToJSONK (Exists k f) x where
gtoJSON (Exists x) = gtoJSON x
instance (forall t. GFromJSONK f (t ':&&: x))
=> GFromJSONK (Exists k f) x where
gfromJSON = fmap Exists . gfromJSON