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


-- | A value constructed using 'qq' that attempts to match
-- a JSON document.
data Matcher ext
  = Hole (Maybe HoleSig) (Maybe Text)
    -- ^ Optionally typed, optionally named _hole.
    -- If a type is provided, the _hole only matches those values
    -- that have that type.
    -- If a name is provided, the matched value is returned
    -- to the user.
  | Null
  | Bool Bool
  | Number Scientific
  | String Text
  | StringCI (CI Text)
    -- ^ Case-insensitive strings
  | Array (Array ext)
  | ArrayUO (Array ext)
    -- ^ Unordered arrays
  | Object (Object ext)
  | Ext ext
    -- ^ External values spliced into a 'Matcher' using the `#{}` syntax
    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
        ]

-- | A wrapper for those matchers that support the `...` syntax.
data Box a = Box
  { forall a. Box a -> a
values :: a
  , forall a. Box a -> Bool
extra  :: Bool
    -- ^ Are extra, not specifically mentioned by a 'Matcher', values
    -- allowed in a 'Value'?
  } 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))

-- | It may be tempting to make this the 'Lift' instance for 'Matcher', but I don't
-- think it would be correct. We can get a lot from re-using 'Lift' machinery: namely,
-- we can cpmpletely bypass manual 'Exp' construction. But, fundamentally, 'Lift' is
-- for "serializing" Haskell values and it is not what we are attempting here.
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 |]
  -- | This is fundamentally type-unsafe as long as we try to splice `Exp` in.
  Ext Exp
ext ->
    [| Ext (toJSONE $(pure ext)) :: Matcher Aeson.Value |]

-- | _hole type signature
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
      ]

-- | _hole type
data Type
  = BoolT
    -- ^ @_ : bool@
  | NumberT
    -- ^ @_ : number@
  | StringT
    -- ^ @_ : string@
  | StringCIT
    -- ^ @_ : ci-string@
  | ArrayT
    -- ^ @_ : array@
  | ArrayUOT
    -- ^ @_ : unordered-array@
  | ObjectT
    -- ^ @_ : object@
    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}