{-# 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
Maintainer  :  Brandon Chinn <brandon@leapyear.io>
Stability   :  experimental
Portability :  portable

Defines a SchemaKey.
-}
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 Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.String (fromString)
import GHC.Generics (Generic)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Language.Haskell.TH.Syntax (Lift)

import qualified Data.Aeson.Schema.Utils.Compat as Compat
import Data.Aeson.Schema.Utils.Invariant (unreachable)

-- | A key in a JSON object schema.
data SchemaKey' s
  = NormalKey s
  | -- | A key that doesn't actually exist in the object, but whose content should be parsed from
    -- the current object.
    PhantomKey s
  deriving (Int -> SchemaKey' s -> ShowS
forall s. Show s => Int -> SchemaKey' s -> ShowS
forall s. Show s => [SchemaKey' s] -> ShowS
forall s. Show s => SchemaKey' s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemaKey' s] -> ShowS
$cshowList :: forall s. Show s => [SchemaKey' s] -> ShowS
show :: SchemaKey' s -> String
$cshow :: forall s. Show s => SchemaKey' s -> String
showsPrec :: Int -> SchemaKey' s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> SchemaKey' s -> ShowS
Show, SchemaKey' s -> SchemaKey' s -> Bool
forall s. Eq s => SchemaKey' s -> SchemaKey' s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SchemaKey' s -> SchemaKey' s -> Bool
$c/= :: forall s. Eq s => SchemaKey' s -> SchemaKey' s -> Bool
== :: SchemaKey' s -> SchemaKey' s -> Bool
$c== :: forall s. Eq s => SchemaKey' s -> SchemaKey' s -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s x. Rep (SchemaKey' s) x -> SchemaKey' s
forall s x. SchemaKey' s -> Rep (SchemaKey' s) x
$cto :: forall s x. Rep (SchemaKey' s) x -> SchemaKey' s
$cfrom :: forall s x. SchemaKey' s -> Rep (SchemaKey' s) x
Generic, forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall {s}. Hashable s => Eq (SchemaKey' s)
forall s. Hashable s => Int -> SchemaKey' s -> Int
forall s. Hashable s => SchemaKey' s -> Int
hash :: SchemaKey' s -> Int
$chash :: forall s. Hashable s => SchemaKey' s -> Int
hashWithSalt :: Int -> SchemaKey' s -> Int
$chashWithSalt :: forall s. Hashable s => Int -> SchemaKey' s -> Int
Hashable, forall s (m :: * -> *). (Lift s, Quote m) => SchemaKey' s -> m Exp
forall s (m :: * -> *).
(Lift s, Quote m) =>
SchemaKey' s -> Code m (SchemaKey' s)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => SchemaKey' s -> m Exp
forall (m :: * -> *).
Quote m =>
SchemaKey' s -> Code m (SchemaKey' s)
liftTyped :: forall (m :: * -> *).
Quote m =>
SchemaKey' s -> Code m (SchemaKey' s)
$cliftTyped :: forall s (m :: * -> *).
(Lift s, Quote m) =>
SchemaKey' s -> Code m (SchemaKey' s)
lift :: forall (m :: * -> *). Quote m => SchemaKey' s -> m Exp
$clift :: forall s (m :: * -> *). (Lift s, Quote m) => SchemaKey' s -> m Exp
Lift)

-- | A value-level SchemaKey
type SchemaKeyV = SchemaKey' String

fromSchemaKeyV :: SchemaKeyV -> String
fromSchemaKeyV :: SchemaKeyV -> String
fromSchemaKeyV (NormalKey String
key) = String
key
fromSchemaKeyV (PhantomKey String
key) = String
key

showSchemaKeyV :: SchemaKeyV -> String
showSchemaKeyV :: SchemaKeyV -> String
showSchemaKeyV (NormalKey String
key) = forall a. Show a => a -> String
show String
key
showSchemaKeyV (PhantomKey String
key) = String
"[" forall a. [a] -> [a] -> [a]
++ String
key forall a. [a] -> [a] -> [a]
++ String
"]"

{- | Given schema `{ key: innerSchema }` for JSON data `{ key: val1 }`, get the JSON
 Value that `innerSchema` should parse.
-}
getContext :: SchemaKeyV -> Aeson.Object -> Aeson.Value
getContext :: SchemaKeyV -> Object -> Value
getContext = \case
  -- `innerSchema` should parse `val1`
  NormalKey String
key -> forall a. a -> Maybe a -> a
fromMaybe Value
Aeson.Null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. Key -> KeyMap v -> Maybe v
Compat.lookup (forall a. IsString a => String -> a
fromString String
key)
  -- `innerSchema` should parse the same object that `key` is in
  PhantomKey String
_ -> Object -> Value
Aeson.Object

{- | Given JSON data `val` adhering to `innerSchema`, get the JSON object that should be
 merged with the outer JSON object.
-}
toContext :: SchemaKeyV -> Aeson.Value -> Aeson.Object
toContext :: SchemaKeyV -> Value -> Object
toContext = \case
  -- `val` should be inserted with key `key`
  NormalKey String
key -> forall v. Key -> v -> KeyMap v
Compat.singleton (forall a. IsString a => String -> a
fromString String
key)
  -- If `val` is an object, it should be merged with the outer JSON object
  PhantomKey String
_ -> \case
    Aeson.Object Object
o -> Object
o
    -- `Try` schema could store `Nothing`, which would return `Null`. In this case, there is no
    -- context to merge
    Value
Aeson.Null -> forall a. Monoid a => a
mempty
    Value
v -> forall a. String -> a
unreachable forall a b. (a -> b) -> a -> b
$ String
"Invalid value for phantom key: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
v

-- | A type-level SchemaKey
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 :: Proxy ('NormalKey key) -> SchemaKeyV
toSchemaKeyV Proxy ('NormalKey key)
_ = forall s. s -> SchemaKey' s
NormalKey forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @key

instance KnownSymbol key => IsSchemaKey ('PhantomKey key) where
  type FromSchemaKey ('PhantomKey key) = key
  toSchemaKeyV :: Proxy ('PhantomKey key) -> SchemaKeyV
toSchemaKeyV Proxy ('PhantomKey key)
_ = forall s. s -> SchemaKey' s
PhantomKey forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @key

fromSchemaKey :: forall key. IsSchemaKey key => String
fromSchemaKey :: forall (key :: SchemaKey). IsSchemaKey key => String
fromSchemaKey = SchemaKeyV -> String
fromSchemaKeyV forall a b. (a -> b) -> a -> b
$ forall (key :: SchemaKey).
IsSchemaKey key =>
Proxy key -> SchemaKeyV
toSchemaKeyV forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @key

showSchemaKey :: forall key. IsSchemaKey key => String
showSchemaKey :: forall (key :: SchemaKey). IsSchemaKey key => String
showSchemaKey = SchemaKeyV -> String
showSchemaKeyV forall a b. (a -> b) -> a -> b
$ forall (key :: SchemaKey).
IsSchemaKey key =>
Proxy key -> SchemaKeyV
toSchemaKeyV forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @key