module Text.DeadSimpleJSON.TH (
jsq,
json,
jsonF,
s,
sF
) where
import Prelude hiding (True, False)
import qualified Prelude
import Data.Char
import qualified Data.Map as M
import qualified Data.Vector as V
import Text.DeadSimpleJSON (parse)
import Text.DeadSimpleJSON.Convert (Convert (..))
import Text.DeadSimpleJSON.Query
import Text.DeadSimpleJSON.Types
import Language.Haskell.TH
import Language.Haskell.TH.Quote
s :: QuasiQuoter
s = QuasiQuoter {
quoteExp = return . LitE . StringL,
quotePat = \_ -> fail "illegal string QuasiQuote (allowed as expression only, used as a pattern)",
quoteType = \_ -> fail "illegal string QuasiQuote (allowed as expression only, used as a type)",
quoteDec = \_ -> fail "illegal string QuasiQuote (allowed as expression only, used as a dec)"
}
sF :: QuasiQuoter
sF = quoteFile s
jsonF :: QuasiQuoter
jsonF = quoteFile json
json :: QuasiQuoter
json = QuasiQuoter {
quoteExp = jsonQuoter,
quotePat = \_ -> fail "illegal json QuasiQuote (allowed as expression only, used as a pattern)",
quoteType = \_ -> fail "illegal json QuasiQuote (allowed as expression only, used as a type)",
quoteDec = \_ -> fail "illegal json QuasiQuote (allowed as expression only, used as a dec)"
}
jsonQuoter :: String -> Q Exp
jsonQuoter = either (fail . show) buildJSON . parse
where
buildJSON (JSON json) = do
json' <- buildJSON' json
return (AppE (ConE 'JSON) json')
buildJSON' (String s) = return $ AppE (ConE 'String) (LitE (StringL s))
buildJSON' (Number n e) = return $ AppE (AppE (ConE 'Number) (LitE (IntegerL n))) (LitE (IntegerL e))
buildJSON' (Object obj) = do
m <- mapM (\(k, v) -> do { x <- buildJSON' v; return $ TupE [LitE (StringL k), x] }) (M.toList obj)
return $ AppE (ConE 'Object) (AppE (VarE 'M.fromList) (ListE m))
buildJSON' (Array arr) = do
v <- mapM buildJSON' (V.toList arr)
return $ AppE (ConE 'Array) (AppE (VarE 'V.fromList) (ListE v))
buildJSON' True = return $ ConE 'True
buildJSON' False = return $ ConE 'False
buildJSON' Null = return $ ConE 'Null
jsq :: QuasiQuoter
jsq = QuasiQuoter {
quoteExp = jsqQuoter,
quotePat = \_ -> fail "illegal jsq QuasiQuote (allowed as expression only, used as a pattern)",
quoteType = \_ -> fail "illegal jsq QuasiQuote (allowed as expression only, used as a type)",
quoteDec = \_ -> fail "illegal jsq QuasiQuote (allowed as expression only, used as a dec)"
}
jsqQuoter :: String -> Q Exp
jsqQuoter = either (fail . show) buildQuery . mkQuery' . filter (not . isSpace)
where
buildQuery (Field s e) = do
q <- buildQuery' e
return $ AppE ((AppE (VarE 'query)) q) (VarE (mkName s))
buildQuery _ = do
report Prelude.False "Warning: Empty JSON Query"
[| convert $ Object M.empty |]
buildQuery' (Field s e) = do
exp <- buildQuery' e
return $ AppE (AppE (ConE 'Field) (LitE (StringL s))) exp
buildQuery' (Index i e) = do
exp <- buildQuery' e
return $ AppE (AppE (ConE 'Index) (LitE (IntegerL (fromIntegral i)))) exp
buildQuery' (Read) = return $ ConE 'Read