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


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

-- | Convert `'Matcher' 'Exp'` to `'Matcher' '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 (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

-- | _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
"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}