{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Aeson.Match.QQ.Internal.Value
( Matcher(..)
, Box(..)
, Array
, Object
, HoleSig(..)
, Type(..)
, embed
, quote
) 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 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.Text (Text)
import qualified Data.Text as Text
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Language.Haskell.TH (Q, Exp(..), Lit(..))
import Language.Haskell.TH.Syntax (Lift(..))
import Prelude hiding (any, null)
import qualified Text.PrettyPrint.HughesPJClass as PP (Pretty(..))
import Aeson.Match.QQ.Internal.AesonUtils (toJSONE)
data Matcher ext
= Hole (Maybe HoleSig) (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 -> Matcher ext -> ShowS
forall ext. Show ext => Int -> Matcher ext -> ShowS
forall ext. Show ext => [Matcher ext] -> ShowS
forall ext. Show ext => Matcher ext -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Matcher ext] -> ShowS
$cshowList :: forall ext. Show ext => [Matcher ext] -> ShowS
show :: Matcher ext -> String
$cshow :: forall ext. Show ext => Matcher ext -> String
showsPrec :: Int -> Matcher ext -> ShowS
$cshowsPrec :: forall ext. Show ext => Int -> Matcher ext -> ShowS
Show, Matcher ext -> Matcher ext -> Bool
forall ext. Eq ext => Matcher ext -> Matcher ext -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Matcher ext -> Matcher ext -> Bool
$c/= :: forall ext. Eq ext => Matcher ext -> Matcher ext -> Bool
== :: Matcher ext -> Matcher ext -> Bool
$c== :: forall ext. Eq ext => Matcher ext -> Matcher ext -> Bool
Eq, forall a b. a -> Matcher b -> Matcher a
forall a b. (a -> b) -> Matcher a -> Matcher b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Matcher b -> Matcher a
$c<$ :: forall a b. a -> Matcher b -> Matcher a
fmap :: forall a b. (a -> b) -> Matcher a -> Matcher b
$cfmap :: forall a b. (a -> b) -> Matcher a -> Matcher b
Functor)
instance Aeson.ToJSON ext => Aeson.ToJSON (Matcher ext) where
toJSON :: Matcher ext -> Value
toJSON =
[Pair] -> Value
Aeson.object forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
Hole Maybe HoleSig
type_ Maybe Text
name ->
[ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"hole" :: Text)
, Key
"expected-type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe HoleSig
type_
, Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
name
]
Matcher 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
values :: a
, :: 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, forall a b. a -> Box b -> Box a
forall a b. (a -> b) -> Box a -> Box b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Box b -> Box a
$c<$ :: forall a b. a -> Box b -> Box a
fmap :: forall a b. (a -> b) -> Box a -> Box b
$cfmap :: forall a b. (a -> b) -> Box a -> Box b
Functor)
instance Aeson.ToJSON a => Aeson.ToJSON (Box a) where
toJSON :: Box a -> Value
toJSON Box {a
Bool
extra :: Bool
values :: a
extra :: forall a. Box a -> Bool
values :: forall a. Box a -> a
..} =
[Pair] -> Value
Aeson.object
[ Key
"values" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
values
, Key
"extra" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
extra
]
type Array ext = Box (Vector (Matcher ext))
type Object ext = Box (HashMap Text (Matcher ext))
quote :: Matcher Exp -> Q Exp
quote :: Matcher Exp -> Q Exp
quote = \case
Hole Maybe HoleSig
type_ Maybe Text
name ->
[| Hole type_ name :: Matcher Aeson.Value |]
Matcher Exp
Null ->
[| Null :: Matcher Aeson.Value |]
Bool Bool
b ->
[| Bool b :: Matcher Aeson.Value |]
Number Scientific
n ->
[| Number n :: Matcher Aeson.Value |]
String Text
str ->
[| String str :: Matcher Aeson.Value |]
StringCI CI Text
ci -> let
original :: Text
original = forall s. CI s -> s
CI.original CI Text
ci
in
[| StringCI (CI.mk original) :: Matcher Aeson.Value |]
Array Box {Vector (Matcher Exp)
values :: Vector (Matcher Exp)
values :: forall a. Box a -> a
values, Bool
extra :: Bool
extra :: forall a. Box a -> Bool
extra} -> do
let
quoted :: Q Exp
quoted =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Matcher Exp -> Q Exp
quote (forall a. Vector a -> [a]
Vector.toList Vector (Matcher Exp)
values))
[| Array Box
{ values = Vector.fromList $quoted
, extra
} :: Matcher Aeson.Value |]
ArrayUO Box {Vector (Matcher Exp)
values :: Vector (Matcher Exp)
values :: forall a. Box a -> a
values, Bool
extra :: Bool
extra :: forall a. Box a -> Bool
extra} -> do
let
quoted :: Q Exp
quoted =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Matcher Exp -> Q Exp
quote (forall a. Vector a -> [a]
Vector.toList Vector (Matcher Exp)
values))
[| ArrayUO Box
{ values = Vector.fromList $quoted
, extra
} :: Matcher Aeson.Value |]
Object Box {HashMap Text (Matcher Exp)
values :: HashMap Text (Matcher Exp)
values :: forall a. Box a -> a
values, Bool
extra :: Bool
extra :: forall a. Box a -> Bool
extra} -> do
let
quoted :: Q Exp
quoted =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Text, Exp)] -> Exp
toExp (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Matcher Exp -> Q Exp
quote) (forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Text (Matcher Exp)
values))
toExp :: [(Text, Exp)] -> Exp
toExp =
[Exp] -> Exp
ListE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, Exp
v) -> (Exp, Exp) -> Exp
tup2 (Lit -> Exp
LitE (String -> Lit
StringL (Text -> String
Text.unpack Text
k)), Exp
v))
tup2 :: (Exp, Exp) -> Exp
tup2 (Exp
a, Exp
b) =
[Maybe Exp] -> Exp
TupE [forall a. a -> Maybe a
Just Exp
a, forall a. a -> Maybe a
Just Exp
b]
[| Object Box
{ values = HashMap.fromList $quoted
, extra
} :: Matcher Aeson.Value |]
Ext Exp
ext ->
[| Ext (toJSONE $(pure ext)) :: Matcher Aeson.Value |]
data HoleSig = HoleSig
{ HoleSig -> Type
type_ :: Type
, HoleSig -> Bool
nullable :: Bool
} deriving (Int -> HoleSig -> ShowS
[HoleSig] -> ShowS
HoleSig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HoleSig] -> ShowS
$cshowList :: [HoleSig] -> ShowS
show :: HoleSig -> String
$cshow :: HoleSig -> String
showsPrec :: Int -> HoleSig -> ShowS
$cshowsPrec :: Int -> HoleSig -> ShowS
Show, HoleSig -> HoleSig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HoleSig -> HoleSig -> Bool
$c/= :: HoleSig -> HoleSig -> Bool
== :: HoleSig -> HoleSig -> Bool
$c== :: HoleSig -> HoleSig -> 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 => HoleSig -> m Exp
forall (m :: * -> *). Quote m => HoleSig -> Code m HoleSig
liftTyped :: forall (m :: * -> *). Quote m => HoleSig -> Code m HoleSig
$cliftTyped :: forall (m :: * -> *). Quote m => HoleSig -> Code m HoleSig
lift :: forall (m :: * -> *). Quote m => HoleSig -> m Exp
$clift :: forall (m :: * -> *). Quote m => HoleSig -> m Exp
Lift)
instance Aeson.ToJSON HoleSig where
toJSON :: HoleSig -> Value
toJSON HoleSig {Bool
Type
nullable :: Bool
type_ :: Type
nullable :: HoleSig -> Bool
type_ :: HoleSig -> 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
.= Bool
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
"ci-string"
ArrayT {} -> Text
"array"
ArrayUOT {} -> Text
"unordered-array"
ObjectT {} -> Text
"object"
instance PP.Pretty Type where
pPrint :: Type -> Doc
pPrint = \case
BoolT {} -> Doc
"bool"
NumberT {} -> Doc
"number"
StringT {} -> Doc
"string"
StringCIT {} -> Doc
"ci-string"
ArrayT {} -> Doc
"array"
ArrayUOT {} -> Doc
"unordered-array"
ObjectT {} -> Doc
"object"
embed :: Aeson.Value -> Matcher ext
embed :: forall ext. Value -> Matcher ext
embed = \case
Value
Aeson.Null ->
forall ext. Matcher ext
Null
Aeson.Bool Bool
b ->
forall ext. Bool -> Matcher ext
Bool Bool
b
Aeson.Number Scientific
n ->
forall ext. Scientific -> Matcher ext
Number Scientific
n
Aeson.String Text
n ->
forall ext. Text -> Matcher ext
String Text
n
Aeson.Array Array
xs ->
forall ext. Array ext -> Matcher ext
Array Box {values :: Vector (Matcher ext)
values = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ext. Value -> Matcher ext
embed Array
xs, extra :: Bool
extra = 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 -> Matcher ext
Object Box {values :: HashMap Text (Matcher ext)
values = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ext. Value -> Matcher ext
embed HashMap Text Value
o, extra :: Bool
extra = Bool
False}