{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Aeson.Match.QQ.Internal.Value
  ( Value(..)
  , Box(..)
  , Array
  , Object
  , TypeSig(..)
  , Type(..)
  , Nullable(..)
  , embed
  ) where

import           Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as Aeson (toHashMapText)
#endif
import qualified Data.Aeson.Encoding.Internal as Aeson (encodingToLazyByteString)
import           Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import           Data.Scientific (Scientific)
import           Data.String (fromString)
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Vector (Vector)
import qualified Data.Vector as Vector
import           Language.Haskell.TH (Exp(..), Lit(..))
import           Language.Haskell.TH.Syntax
  ( Lift(..)
#if MIN_VERSION_template_haskell(2,17,0)
  , unsafeCodeCoerce
#else
  , unsafeTExpCoerce
#endif
  )
import           Prelude hiding (any, null)


data Value ext
  = Any (Maybe TypeSig) (Maybe Text)
  | Null
  | Bool Bool
  | Number Scientific
  | String Text
  | StringCI (CI Text)
  | Array (Array ext)
  | ArrayUO (Array ext)
  | Object (Object ext)
  | Ext ext
    deriving (Int -> Value ext -> ShowS
forall ext. Show ext => Int -> Value ext -> ShowS
forall ext. Show ext => [Value ext] -> ShowS
forall ext. Show ext => Value ext -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value ext] -> ShowS
$cshowList :: forall ext. Show ext => [Value ext] -> ShowS
show :: Value ext -> String
$cshow :: forall ext. Show ext => Value ext -> String
showsPrec :: Int -> Value ext -> ShowS
$cshowsPrec :: forall ext. Show ext => Int -> Value ext -> ShowS
Show, Value ext -> Value ext -> Bool
forall ext. Eq ext => Value ext -> Value ext -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value ext -> Value ext -> Bool
$c/= :: forall ext. Eq ext => Value ext -> Value ext -> Bool
== :: Value ext -> Value ext -> Bool
$c== :: forall ext. Eq ext => Value ext -> Value ext -> Bool
Eq)

instance Aeson.ToJSON ext => Aeson.ToJSON (Value ext) where
  toJSON :: Value ext -> Value
toJSON =
    [Pair] -> Value
Aeson.object forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Any Maybe TypeSig
type_ Maybe Text
name ->
        [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"any" :: Text)
        , Key
"expected-type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe TypeSig
type_
        , Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
name
        ]
      Value ext
Null ->
        [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"null" :: Text)
        ]
      Bool Bool
v ->
        [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"bool" :: Text)
        , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
v
        ]
      Number Scientific
v ->
        [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"number" :: Text)
        , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Scientific
v
        ]
      String Text
v ->
        [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"string" :: Text)
        , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
v
        ]
      StringCI CI Text
v ->
        [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"string-ci" :: Text)
        , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s. CI s -> s
CI.original CI Text
v
        ]
      Array Array ext
v ->
        [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"array" :: Text)
        , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Array ext
v
        ]
      ArrayUO Array ext
v ->
        [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"array-unordered" :: Text)
        , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Array ext
v
        ]
      Object Object ext
v ->
        [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"object" :: Text)
        , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Object ext
v
        ]
      Ext ext
v ->
        [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"extension" :: Text)
        , Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ext
v
        ]

data Box a = Box
  { forall a. Box a -> a
knownValues :: a
  , forall a. Box a -> Bool
extendable  :: Bool
  } deriving (Int -> Box a -> ShowS
forall a. Show a => Int -> Box a -> ShowS
forall a. Show a => [Box a] -> ShowS
forall a. Show a => Box a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Box a] -> ShowS
$cshowList :: forall a. Show a => [Box a] -> ShowS
show :: Box a -> String
$cshow :: forall a. Show a => Box a -> String
showsPrec :: Int -> Box a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Box a -> ShowS
Show, Box a -> Box a -> Bool
forall a. Eq a => Box a -> Box a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Box a -> Box a -> Bool
$c/= :: forall a. Eq a => Box a -> Box a -> Bool
== :: Box a -> Box a -> Bool
$c== :: forall a. Eq a => Box a -> Box a -> Bool
Eq)

instance Aeson.ToJSON a => Aeson.ToJSON (Box a) where
  toJSON :: Box a -> Value
toJSON Box {a
Bool
extendable :: Bool
knownValues :: a
extendable :: forall a. Box a -> Bool
knownValues :: forall a. Box a -> a
..} =
    [Pair] -> Value
Aeson.object
      [ Key
"known-values" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
knownValues
      , Key
"extendable" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
extendable
      ]

type Array ext = Box (Vector (Value ext))

type Object ext = Box (HashMap Text (Value ext))

-- | Convert `Value Exp` to `Value Aeson.Value`. This uses a roundabout way to get
-- `Aeson.Value` from `ToJSON.toEncoding` to avoid calling `Aeson.toJSON` which may be
-- undefined for some datatypes.
instance ext ~ Exp => Lift (Value ext) where
  lift :: forall (m :: * -> *). Quote m => Value ext -> m Exp
lift = \case
    Any Maybe TypeSig
type_ Maybe Text
name ->
      [| Any type_ $(pure (maybe (ConE 'Nothing) (AppE (ConE 'Just) . AppE (VarE 'fromString) . LitE . textL) name)) :: Value Aeson.Value |]
    Value ext
Null ->
      [| Null :: Value Aeson.Value |]
    Bool Bool
b ->
      [| Bool b :: Value Aeson.Value |]
    Number Scientific
n ->
      [| Number (fromRational $(pure (LitE (RationalL (toRational n))))) :: Value Aeson.Value |]
    String Text
str ->
      [| String (fromString $(pure (LitE (textL str)))) :: Value Aeson.Value |]
    StringCI CI Text
str ->
      [| StringCI (fromString $(pure (LitE (textL (CI.original str))))) :: Value Aeson.Value |]
    Array Box {Vector (Value ext)
knownValues :: Vector (Value ext)
knownValues :: forall a. Box a -> a
knownValues, Bool
extendable :: Bool
extendable :: forall a. Box a -> Bool
extendable} -> [|
        Array Box
          { knownValues =
              Vector.fromList $(fmap (ListE . Vector.toList) (traverse lift knownValues))
          , extendable
          } :: Value Aeson.Value
      |]
    ArrayUO Box {Vector (Value ext)
knownValues :: Vector (Value ext)
knownValues :: forall a. Box a -> a
knownValues, Bool
extendable :: Bool
extendable :: forall a. Box a -> Bool
extendable} -> [|
        ArrayUO Box
          { knownValues =
              Vector.fromList $(fmap (ListE . Vector.toList) (traverse lift knownValues))
          , extendable
          } :: Value Aeson.Value
      |]
    Object Box {HashMap Text (Value ext)
knownValues :: HashMap Text (Value ext)
knownValues :: forall a. Box a -> a
knownValues, Bool
extendable :: Bool
extendable :: forall a. Box a -> Bool
extendable} -> [|
        Object Box
          { knownValues =
              HashMap.fromList $(fmap (ListE . map (\(k, v) -> TupE [Just (LitE (textL k)), Just v]) . HashMap.toList) (traverse lift knownValues))
          , extendable
          } :: Value Aeson.Value
      |]
    Ext ext
ext ->
      [| Ext (let ~(Just val) = Aeson.decode (Aeson.encodingToLazyByteString (Aeson.toEncoding $(pure ext))) in val) :: Value Aeson.Value |]
   where
    textL :: Text -> Lit
textL =
      String -> Lit
StringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
  liftTyped :: forall (m :: * -> *). Quote m => Value ext -> Code m (Value ext)
liftTyped =
#if MIN_VERSION_template_haskell(2,17,0)
    forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift
#else
    unsafeTExpCoerce . lift
#endif

data TypeSig = TypeSig
  { TypeSig -> Type
type_    :: Type
  , TypeSig -> Nullable
nullable :: Nullable
  } deriving (Int -> TypeSig -> ShowS
[TypeSig] -> ShowS
TypeSig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeSig] -> ShowS
$cshowList :: [TypeSig] -> ShowS
show :: TypeSig -> String
$cshow :: TypeSig -> String
showsPrec :: Int -> TypeSig -> ShowS
$cshowsPrec :: Int -> TypeSig -> ShowS
Show, TypeSig -> TypeSig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeSig -> TypeSig -> Bool
$c/= :: TypeSig -> TypeSig -> Bool
== :: TypeSig -> TypeSig -> Bool
$c== :: TypeSig -> TypeSig -> Bool
Eq, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => TypeSig -> m Exp
forall (m :: * -> *). Quote m => TypeSig -> Code m TypeSig
liftTyped :: forall (m :: * -> *). Quote m => TypeSig -> Code m TypeSig
$cliftTyped :: forall (m :: * -> *). Quote m => TypeSig -> Code m TypeSig
lift :: forall (m :: * -> *). Quote m => TypeSig -> m Exp
$clift :: forall (m :: * -> *). Quote m => TypeSig -> m Exp
Lift)

instance Aeson.ToJSON TypeSig where
  toJSON :: TypeSig -> Value
toJSON TypeSig {Nullable
Type
nullable :: Nullable
type_ :: Type
nullable :: TypeSig -> Nullable
type_ :: TypeSig -> Type
..} =
    [Pair] -> Value
Aeson.object
      [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Type
type_
      , Key
"nullable" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Nullable
nullable
      ]

data Type
  = BoolT
  | NumberT
  | StringT
  | StringCIT
  | ArrayT
  | ArrayUOT
  | ObjectT
    deriving (Int -> Type -> ShowS
[Type] -> ShowS
Type -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Type] -> ShowS
$cshowList :: [Type] -> ShowS
show :: Type -> String
$cshow :: Type -> String
showsPrec :: Int -> Type -> ShowS
$cshowsPrec :: Int -> Type -> ShowS
Show, Type -> Type -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Type -> m Exp
forall (m :: * -> *). Quote m => Type -> Code m Type
liftTyped :: forall (m :: * -> *). Quote m => Type -> Code m Type
$cliftTyped :: forall (m :: * -> *). Quote m => Type -> Code m Type
lift :: forall (m :: * -> *). Quote m => Type -> m Exp
$clift :: forall (m :: * -> *). Quote m => Type -> m Exp
Lift)

instance Aeson.ToJSON Type where
  toJSON :: Type -> Value
toJSON =
    forall a. ToJSON a => a -> Value
Aeson.toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      BoolT {} -> Text
"bool" :: Text
      NumberT {} -> Text
"number"
      StringT {} -> Text
"string"
      StringCIT {} -> Text
"string-ci"
      ArrayT {} -> Text
"array"
      ArrayUOT {} -> Text
"array-unordered"
      ObjectT {} -> Text
"object"

data Nullable
  = Nullable
  | NonNullable
    deriving (Int -> Nullable -> ShowS
[Nullable] -> ShowS
Nullable -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Nullable] -> ShowS
$cshowList :: [Nullable] -> ShowS
show :: Nullable -> String
$cshow :: Nullable -> String
showsPrec :: Int -> Nullable -> ShowS
$cshowsPrec :: Int -> Nullable -> ShowS
Show, Nullable -> Nullable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Nullable -> Nullable -> Bool
$c/= :: Nullable -> Nullable -> Bool
== :: Nullable -> Nullable -> Bool
$c== :: Nullable -> Nullable -> Bool
Eq, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Nullable -> m Exp
forall (m :: * -> *). Quote m => Nullable -> Code m Nullable
liftTyped :: forall (m :: * -> *). Quote m => Nullable -> Code m Nullable
$cliftTyped :: forall (m :: * -> *). Quote m => Nullable -> Code m Nullable
lift :: forall (m :: * -> *). Quote m => Nullable -> m Exp
$clift :: forall (m :: * -> *). Quote m => Nullable -> m Exp
Lift)

instance Aeson.ToJSON Nullable where
  toJSON :: Nullable -> Value
toJSON =
    forall a. ToJSON a => a -> Value
Aeson.toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Nullable
Nullable -> Bool
True
      Nullable
NonNullable -> Bool
False

embed :: Aeson.Value -> Value ext
embed :: forall ext. Value -> Value ext
embed = \case
  Value
Aeson.Null ->
    forall ext. Value ext
Null
  Aeson.Bool Bool
b ->
    forall ext. Bool -> Value ext
Bool Bool
b
  Aeson.Number Scientific
n ->
    forall ext. Scientific -> Value ext
Number Scientific
n
  Aeson.String Text
n ->
    forall ext. Text -> Value ext
String Text
n
  Aeson.Array Array
xs ->
    forall ext. Array ext -> Value ext
Array Box {knownValues :: Vector (Value ext)
knownValues = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ext. Value -> Value ext
embed Array
xs, extendable :: Bool
extendable = Bool
False}
#if MIN_VERSION_aeson(2,0,0)
  Aeson.Object (forall v. KeyMap v -> HashMap Text v
Aeson.toHashMapText -> HashMap Text Value
o) ->
#else
  Aeson.Object o ->
#endif
    forall ext. Object ext -> Value ext
Object Box {knownValues :: HashMap Text (Value ext)
knownValues = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ext. Value -> Value ext
embed HashMap Text Value
o, extendable :: Bool
extendable = Bool
False}