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

import           Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encoding.Internal as Aeson (encodingToLazyByteString)
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(..), unsafeTExpCoerce)
import           Prelude hiding (any, null)


data Value ext
  = Any (Maybe TypeSig) (Maybe Text)
  | Null
  | Bool Bool
  | Number Scientific
  | String Text
  | Array (Array ext)
  | Object (Object ext)
  | Ext ext
    deriving (Int -> Value ext -> ShowS
[Value ext] -> ShowS
Value ext -> String
(Int -> Value ext -> ShowS)
-> (Value ext -> String)
-> ([Value ext] -> ShowS)
-> Show (Value ext)
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
(Value ext -> Value ext -> Bool)
-> (Value ext -> Value ext -> Bool) -> Eq (Value ext)
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 ([Pair] -> Value) -> (Value ext -> [Pair]) -> Value ext -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Any Maybe TypeSig
type_ Maybe Text
name ->
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"any" :: Text)
        , Key
"expected-type" Key -> Maybe TypeSig -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe TypeSig
type_
        , Key
"name" Key -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
name
        ]
      Value ext
Null ->
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"null" :: Text)
        ]
      Bool Bool
v ->
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"bool" :: Text)
        , Key
"value" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
v
        ]
      Number Scientific
v ->
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"number" :: Text)
        , Key
"value" Key -> Scientific -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Scientific
v
        ]
      String Text
v ->
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"string" :: Text)
        , Key
"value" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
v
        ]
      Array Array ext
v ->
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"array" :: Text)
        , Key
"value" Key -> Array ext -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Array ext
v
        ]
      Object Object ext
v ->
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"object" :: Text)
        , Key
"value" Key -> Object ext -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Object ext
v
        ]
      Ext ext
v ->
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"extension" :: Text)
        , Key
"value" Key -> ext -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ext
v
        ]

data Box a = Box
  { Box a -> a
knownValues :: a
  , Box a -> Bool
extendable  :: Bool
  } deriving (Int -> Box a -> ShowS
[Box a] -> ShowS
Box a -> String
(Int -> Box a -> ShowS)
-> (Box a -> String) -> ([Box a] -> ShowS) -> Show (Box a)
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
(Box a -> Box a -> Bool) -> (Box a -> Box a -> Bool) -> Eq (Box a)
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" Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
knownValues
      , Key
"extendable" Key -> Bool -> Pair
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 :: Value ext -> Q 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 |]
    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
      |]
    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 (String -> Lit) -> (Text -> String) -> Text -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
  liftTyped :: Value ext -> Q (TExp (Value ext))
liftTyped =
    Q Exp -> Q (TExp (Value ext))
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp (Value ext)))
-> (Value ext -> Q Exp) -> Value ext -> Q (TExp (Value ext))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value ext -> Q Exp
forall t. Lift t => t -> Q Exp
lift

data TypeSig = TypeSig
  { TypeSig -> Type
type_    :: Type
  , TypeSig -> Nullable
nullable :: Nullable
  } deriving (Int -> TypeSig -> ShowS
[TypeSig] -> ShowS
TypeSig -> String
(Int -> TypeSig -> ShowS)
-> (TypeSig -> String) -> ([TypeSig] -> ShowS) -> Show TypeSig
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
(TypeSig -> TypeSig -> Bool)
-> (TypeSig -> TypeSig -> Bool) -> Eq TypeSig
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, TypeSig -> Q Exp
TypeSig -> Q (TExp TypeSig)
(TypeSig -> Q Exp) -> (TypeSig -> Q (TExp TypeSig)) -> Lift TypeSig
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: TypeSig -> Q (TExp TypeSig)
$cliftTyped :: TypeSig -> Q (TExp TypeSig)
lift :: TypeSig -> Q Exp
$clift :: TypeSig -> Q 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" Key -> Type -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Type
type_
      , Key
"nullable" Key -> Nullable -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Nullable
nullable
      ]

data Type
  = BoolT
  | NumberT
  | StringT
  | ArrayT
  | ObjectT
    deriving (Int -> Type -> ShowS
[Type] -> ShowS
Type -> String
(Int -> Type -> ShowS)
-> (Type -> String) -> ([Type] -> ShowS) -> Show Type
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
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
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, Type -> Q Exp
Type -> Q (TExp Type)
(Type -> Q Exp) -> (Type -> Q (TExp Type)) -> Lift Type
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Type -> Q (TExp Type)
$cliftTyped :: Type -> Q (TExp Type)
lift :: Type -> Q Exp
$clift :: Type -> Q Exp
Lift)

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

data Nullable
  = Nullable
  | NonNullable
    deriving (Int -> Nullable -> ShowS
[Nullable] -> ShowS
Nullable -> String
(Int -> Nullable -> ShowS)
-> (Nullable -> String) -> ([Nullable] -> ShowS) -> Show Nullable
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
(Nullable -> Nullable -> Bool)
-> (Nullable -> Nullable -> Bool) -> Eq Nullable
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, Nullable -> Q Exp
Nullable -> Q (TExp Nullable)
(Nullable -> Q Exp)
-> (Nullable -> Q (TExp Nullable)) -> Lift Nullable
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Nullable -> Q (TExp Nullable)
$cliftTyped :: Nullable -> Q (TExp Nullable)
lift :: Nullable -> Q Exp
$clift :: Nullable -> Q Exp
Lift)

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