{-# 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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
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 $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)
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, $(toExp value))|]
          HashVarKey String
k -> [|(fromString $(dyn k), $(toExp value))|]
toExp (JsonArray [JsonValue]
arr) = [|Array $ V.fromList $(ListE <$> mapM toExp arr)|]
toExp (JsonNumber Scientific
n) = [|Number (fromRational $(return $ LitE $ RationalL (toRational n)))|]
toExp (JsonBool Bool
b) = [|Bool b|]
toExp (JsonCode Exp
e) = [|toJSON $(return e)|]