{-# 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
) 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 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))
instance ext ~ Exp => Lift (Matcher ext) where
lift :: forall (m :: * -> *). Quote m => Matcher ext -> m Exp
lift = \case
Hole Maybe HoleSig
type_ Maybe Text
name ->
[| Hole type_ $(pure (maybe (ConE 'Nothing) (AppE (ConE 'Just) . AppE (VarE 'fromString) . LitE . textL) name)) :: Matcher Aeson.Value |]
Matcher ext
Null ->
[| Null :: Matcher Aeson.Value |]
Bool Bool
b ->
[| Bool b :: Matcher Aeson.Value |]
Number Scientific
n ->
[| Number (fromRational $(pure (LitE (RationalL (toRational n))))) :: Matcher Aeson.Value |]
String Text
str ->
[| String (fromString $(pure (LitE (textL str)))) :: Matcher Aeson.Value |]
StringCI CI Text
str ->
[| StringCI (fromString $(pure (LitE (textL (CI.original str))))) :: Matcher Aeson.Value |]
Array Box {Vector (Matcher ext)
values :: Vector (Matcher ext)
values :: forall a. Box a -> a
values, Bool
extra :: Bool
extra :: forall a. Box a -> Bool
extra} -> [|
Array Box
{ values =
Vector.fromList $(fmap (ListE . Vector.toList) (traverse lift values))
, extra
} :: Matcher Aeson.Value
|]
ArrayUO Box {Vector (Matcher ext)
values :: Vector (Matcher ext)
values :: forall a. Box a -> a
values, Bool
extra :: Bool
extra :: forall a. Box a -> Bool
extra} -> [|
ArrayUO Box
{ values =
Vector.fromList $(fmap (ListE . Vector.toList) (traverse lift values))
, extra
} :: Matcher Aeson.Value
|]
Object Box {HashMap Text (Matcher ext)
values :: HashMap Text (Matcher ext)
values :: forall a. Box a -> a
values, Bool
extra :: Bool
extra :: forall a. Box a -> Bool
extra} -> [|
Object Box
{ values =
HashMap.fromList $(fmap (ListE . map (\(k, v) -> TupE [Just (LitE (textL k)), Just v]) . HashMap.toList) (traverse lift values))
, extra
} :: Matcher Aeson.Value
|]
Ext ext
ext ->
[| Ext (let ~(Just val) = Aeson.decode (Aeson.encodingToLazyByteString (Aeson.toEncoding $(pure ext))) in val) :: Matcher 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 =>
Matcher ext -> Code m (Matcher 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 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
"array-unordered"
ObjectT {} -> Text
"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}