module Data.Aeson.QQ (
aesonQQ
) where
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Data.Data
import Data.Maybe
import Data.JSON.QQ as QQ
import Data.Aeson as A
import Data.Aeson.Generic
import Data.Ratio
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Error
import Language.Haskell.Meta.Parse
aesonQQ :: QuasiQuoter
aesonQQ = QuasiQuoter {
quoteExp = jsonExp,
quotePat = \s -> error "No quotePat defined for jsonQQ",
quoteType = \s -> error "No quoteType defined for jsonQQ",
quoteDec = \s -> error "No quoteDec defined for jsonQQ"
}
jsonExp :: String -> ExpQ
jsonExp txt =
case parsed' of
Left err -> error $ "Error in aesonExp: " ++ show err
Right val -> return $toExp val
where
parsed' = QQ.parsedJson txt
toExp :: QQ.JsonValue -> Exp
toExp (JsonString str) =
AppE (ConE $ mkName "Data.Aeson.Types.String") (packE (LitE (StringL $ str)))
toExp (JsonNull) = ConE $ mkName "Data.Aeson.Types.Null"
toExp (JsonObject objs) =
(AppE (VarE $ mkName "Data.Aeson.Types.object") (ListE $ jsList ))
where
jsList :: [Exp]
jsList = map objs2list (objs)
objs2list :: (HashKey,JsonValue) -> Exp
objs2list (HashStringKey k,v) = TupE [packE (LitE (StringL k)), toExp v]
objs2list (HashVarKey k,v) = TupE [packE (VarE $ mkName k), toExp v]
toExp (JsonArray arr) =
AppE (ConE $ mkName "Data.Aeson.Types.Array") (AppE (VarE $ mkName "Data.Vector.fromList") (ListE $ map toExp arr))
toExp (JsonNumber b rat) =
AppE (ConE $ mkName "Data.Aeson.Types.Number") (AppE (ConE $ mkName "Data.Attoparsec.Number.D") (LitE (RationalL rat)))
toExp (JsonIdVar v) =
VarE $ mkName v
toExp (JsonBool b) =
AppE (ConE $ mkName "Data.Aeson.Types.Bool") (ConE $ mkName (if b then "True" else "False"))
toExp (JsonCode exp) =
AppE (VarE $ mkName "Data.Aeson.Generic.toJSON") exp
packE = AppE (VarE $ mkName "Data.Text.pack")