{-# LANGUAGE TemplateHaskell #-}
-- | Have a look at the <https://github.com/sol/aeson-qq#readme README> for
-- documentation.
module Data.Aeson.QQ (aesonQQ) where

import Prelude ()
import Prelude.Compat

import Language.Haskell.TH
import Language.Haskell.TH.Quote

import qualified Data.Vector as V
import Data.String (fromString)
import qualified Data.Text as T
import Data.Aeson

import Data.JSON.QQ as QQ

aesonQQ :: QuasiQuoter
aesonQQ :: QuasiQuoter
aesonQQ = QuasiQuoter {
  quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
jsonExp,
  quotePat :: String -> Q Pat
quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall a. HasCallStack => String -> a
error String
"No quotePat defined for jsonQQ",
  quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall a. HasCallStack => String -> a
error String
"No quoteType defined for jsonQQ",
  quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"No quoteDec defined for jsonQQ"
}


jsonExp :: String -> ExpQ
jsonExp :: String -> Q Exp
jsonExp String
txt =
  case Either ParseError JsonValue
parsed' of
    Left ParseError
err -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Error in aesonExp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
    Right JsonValue
val -> JsonValue -> Q Exp
toExp JsonValue
val
  where
    parsed' :: Either ParseError JsonValue
parsed' = String -> Either ParseError JsonValue
QQ.parsedJson String
txt

----
-- JSValue etc to ExpQ
---------
toExp :: QQ.JsonValue -> ExpQ
toExp :: JsonValue -> Q Exp
toExp (JsonString String
str) = [|String (T.pack str)|]
toExp (JsonValue
JsonNull) = [|Null|]
toExp (JsonObject [(HashKey, JsonValue)]
objs) = [|object $Q Exp
jsList|]
    where
      jsList :: ExpQ
      jsList :: Q Exp
jsList = [Exp] -> Exp
ListE ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((HashKey, JsonValue) -> Q Exp)
-> [(HashKey, JsonValue)] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (HashKey, JsonValue) -> Q Exp
objs2list ([(HashKey, JsonValue)]
objs)

      objs2list :: (HashKey, JsonValue) -> ExpQ
      objs2list :: (HashKey, JsonValue) -> Q Exp
objs2list (HashKey
key, JsonValue
value) = do
        case HashKey
key of
          HashStringKey String
k -> [|(fromString k, $(JsonValue -> Q Exp
toExp JsonValue
value))|]
          HashVarKey String
k -> [|(fromString $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
dyn String
k), $(JsonValue -> Q Exp
toExp JsonValue
value))|]
toExp (JsonArray [JsonValue]
arr) = [|Array $ V.fromList $([Exp] -> Exp
ListE ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JsonValue -> Q Exp) -> [JsonValue] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM JsonValue -> Q Exp
toExp [JsonValue]
arr)|]
toExp (JsonNumber Scientific
n) = [|Number (fromRational $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ Rational -> Lit
RationalL (Scientific -> Rational
forall a. Real a => a -> Rational
toRational Scientific
n)))|]
toExp (JsonBool Bool
b) = [|Bool b|]
toExp (JsonCode Exp
e) = [|toJSON $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e)|]