{-# 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))
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