{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
module Data.Aeson.Schema.Key
( SchemaKey'(..)
, SchemaKeyV
, fromSchemaKeyV
, showSchemaKeyV
, getContext
, toContext
, SchemaKey
, IsSchemaKey(..)
, fromSchemaKey
, showSchemaKey
) where
import qualified Data.Aeson as Aeson
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as HashMap
import Data.Proxy (Proxy(..))
import qualified Data.Text as Text
import GHC.Generics (Generic)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Language.Haskell.TH.Syntax (Lift)
import Data.Aeson.Schema.Utils.Invariant (unreachable)
data SchemaKey' s
= NormalKey s
| PhantomKey s
deriving (Show, Eq, Generic, Hashable, Lift)
type SchemaKeyV = SchemaKey' String
fromSchemaKeyV :: SchemaKeyV -> String
fromSchemaKeyV (NormalKey key) = key
fromSchemaKeyV (PhantomKey key) = key
showSchemaKeyV :: SchemaKeyV -> String
showSchemaKeyV (NormalKey key) = show key
showSchemaKeyV (PhantomKey key) = "[" ++ key ++ "]"
getContext :: SchemaKeyV -> Aeson.Object -> Aeson.Value
getContext = \case
NormalKey key -> HashMap.lookupDefault Aeson.Null (Text.pack key)
PhantomKey _ -> Aeson.Object
toContext :: SchemaKeyV -> Aeson.Value -> Aeson.Object
toContext = \case
NormalKey key -> HashMap.singleton (Text.pack key)
PhantomKey _ -> \case
Aeson.Object o -> o
Aeson.Null -> mempty
v -> unreachable $ "Invalid value for phantom key: " ++ show v
type SchemaKey = SchemaKey' Symbol
class KnownSymbol (FromSchemaKey key) => IsSchemaKey (key :: SchemaKey) where
type FromSchemaKey key :: Symbol
toSchemaKeyV :: Proxy key -> SchemaKeyV
instance KnownSymbol key => IsSchemaKey ('NormalKey key) where
type FromSchemaKey ('NormalKey key) = key
toSchemaKeyV _ = NormalKey $ symbolVal $ Proxy @key
instance KnownSymbol key => IsSchemaKey ('PhantomKey key) where
type FromSchemaKey ('PhantomKey key) = key
toSchemaKeyV _ = PhantomKey $ symbolVal $ Proxy @key
fromSchemaKey :: forall key. IsSchemaKey key => String
fromSchemaKey = fromSchemaKeyV $ toSchemaKeyV $ Proxy @key
showSchemaKey :: forall key. IsSchemaKey key => String
showSchemaKey = showSchemaKeyV $ toSchemaKeyV $ Proxy @key