PrefixJSON.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module PrefixJSON where

import Data.Aeson
import qualified Data.Aeson.KeyMap as KM
import Data.Kind
import Data.Proxy
import Data.String
import GHC.Generics (Generic)
import GHC.Generics.Generically
import GHC.TypeLits

type PrefixJSON :: Symbol -> Type -> Type
newtype PrefixJSON p a = PrefixJSON a

instance (ToJSON a, KnownSymbol p) => ToJSON (PrefixJSON p a) where
  toJSON (PrefixJSON a) = object [fromString key .= a]
    where
      key = symbolVal (Proxy @p)

instance (FromJSON a, KnownSymbol p) => FromJSON (PrefixJSON p a) where
  parseJSON = withObject ("PrefixJSON " <> show key) $ \o ->
    case KM.toList o of
      [(k, v)] | k == fromString key -> PrefixJSON <$> parseJSON v
      _ -> fail $ "expected " <> show key <> " as the only entry"
    where
      key = symbolVal (Proxy @p)

type PrefixesJSON :: [Symbol] -> Type -> Type
type family PrefixesJSON ps a where
  PrefixesJSON '[] a = a
  PrefixesJSON (p ': ps) a = PrefixJSON p (PrefixesJSON ps a)

data Foo = Foo
  { foo :: Int,
    bar :: Bool
  }
  deriving stock (Show, Generic)
  deriving
    (FromJSON, ToJSON)
    via (PrefixesJSON '["wrapped", "in", "here"] (Generically Foo))