module Text.JSON.YAJL
(
Parser
, ParserCallbacks (..)
, ParseStatus (..)
, newParser
, parseUTF8
, parseText
, parseComplete
, getBytesConsumed
, Generator
, GeneratorConfig (..)
, GeneratorError (..)
, newGenerator
, getBuffer
, clearBuffer
, generateNull
, generateBoolean
, generateIntegral
, generateDouble
, generateNumber
, generateText
, generateBeginArray
, generateEndArray
, generateBeginObject
, generateEndObject
) where
import qualified Control.Exception as E
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as BU
import qualified Data.ByteString.Char8 as BC
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Typeable (Typeable)
import qualified Foreign.Concurrent as FC
import qualified Data.IORef as I
import Foreign
import Foreign.C
data Parser = Parser
{ parserHandle :: ForeignPtr ParserHandle
, parserCallbacks :: ForeignPtr ()
, parserErrorRef :: I.IORef (Maybe E.SomeException)
}
data ParserCallbacks = ParserCallbacks
{ parsedNull :: IO Bool
, parsedBoolean :: Bool -> IO Bool
, parsedNumber :: B.ByteString -> IO Bool
, parsedText :: T.Text -> IO Bool
, parsedBeginArray :: IO Bool
, parsedEndArray :: IO Bool
, parsedBeginObject :: IO Bool
, parsedAttributeName :: T.Text -> IO Bool
, parsedEndObject :: IO Bool
}
data ParseStatus
= ParseFinished
| ParseContinue
| ParseCancelled
| ParseError T.Text
deriving (Show, Eq)
newtype ParserHandle = ParserHandle (Ptr (ParserHandle))
newParser :: ParserCallbacks -> IO Parser
newParser callbacks = do
ref <- I.newIORef Nothing
cCallbacks <- mallocForeignPtrBytes 44
withForeignPtr cCallbacks $ \raw -> do
wrapCallback0 ref (parsedNull callbacks)
>>= (\ptr val -> do {pokeByteOff ptr 0 (val::(FunPtr ((Ptr ()) -> (IO CInt))))}) raw
wrapCallbackBool ref (parsedBoolean callbacks)
>>= (\ptr val -> do {pokeByteOff ptr 4 (val::(FunPtr ((Ptr ()) -> (CInt -> (IO CInt)))))}) raw
wrapCallbackNum ref (parsedNumber callbacks)
>>= (\ptr val -> do {pokeByteOff ptr 16 (val::(FunPtr ((Ptr ()) -> ((Ptr CChar) -> (CUInt -> (IO CInt))))))}) raw
wrapCallbackText ref (parsedText callbacks)
>>= (\ptr val -> do {pokeByteOff ptr 20 (val::(FunPtr ((Ptr ()) -> ((Ptr CUChar) -> (CUInt -> (IO CInt))))))}) raw
wrapCallback0 ref (parsedBeginObject callbacks)
>>= (\ptr val -> do {pokeByteOff ptr 24 (val::(FunPtr ((Ptr ()) -> (IO CInt))))}) raw
wrapCallbackText ref (parsedAttributeName callbacks)
>>= (\ptr val -> do {pokeByteOff ptr 28 (val::(FunPtr ((Ptr ()) -> ((Ptr CUChar) -> (CUInt -> (IO CInt))))))}) raw
wrapCallback0 ref (parsedEndObject callbacks)
>>= (\ptr val -> do {pokeByteOff ptr 32 (val::(FunPtr ((Ptr ()) -> (IO CInt))))}) raw
wrapCallback0 ref (parsedBeginArray callbacks)
>>= (\ptr val -> do {pokeByteOff ptr 36 (val::(FunPtr ((Ptr ()) -> (IO CInt))))}) raw
wrapCallback0 ref (parsedEndArray callbacks)
>>= (\ptr val -> do {pokeByteOff ptr 40 (val::(FunPtr ((Ptr ()) -> (IO CInt))))}) raw
(\ptr val -> do {pokeByteOff ptr 8 (val::(FunPtr ((Ptr ()) -> (CLong -> (IO CInt)))))}) raw nullFunPtr
(\ptr val -> do {pokeByteOff ptr 12 (val::(FunPtr ((Ptr ()) -> (CDouble -> (IO CInt)))))}) raw nullFunPtr
FC.addForeignPtrFinalizer cCallbacks $ freeParserCallbacks raw
ParserHandle handlePtr <- withForeignPtr cCallbacks $ \ptr ->
yajl_alloc ptr nullPtr nullPtr nullPtr
parserFP <- newForeignPtr cParserFree handlePtr
return $ Parser parserFP cCallbacks ref
freeParserCallbacks :: Ptr () -> IO ()
freeParserCallbacks raw = do
(\ptr -> do {peekByteOff ptr 0 ::IO (FunPtr ((Ptr ()) -> (IO CInt)))}) raw >>= freeHaskellFunPtr
(\ptr -> do {peekByteOff ptr 4 ::IO (FunPtr ((Ptr ()) -> (CInt -> (IO CInt))))}) raw >>= freeHaskellFunPtr
(\ptr -> do {peekByteOff ptr 16 ::IO (FunPtr ((Ptr ()) -> ((Ptr CChar) -> (CUInt -> (IO CInt)))))}) raw >>= freeHaskellFunPtr
(\ptr -> do {peekByteOff ptr 20 ::IO (FunPtr ((Ptr ()) -> ((Ptr CUChar) -> (CUInt -> (IO CInt)))))}) raw >>= freeHaskellFunPtr
(\ptr -> do {peekByteOff ptr 24 ::IO (FunPtr ((Ptr ()) -> (IO CInt)))}) raw >>= freeHaskellFunPtr
(\ptr -> do {peekByteOff ptr 28 ::IO (FunPtr ((Ptr ()) -> ((Ptr CUChar) -> (CUInt -> (IO CInt)))))}) raw >>= freeHaskellFunPtr
(\ptr -> do {peekByteOff ptr 32 ::IO (FunPtr ((Ptr ()) -> (IO CInt)))}) raw >>= freeHaskellFunPtr
(\ptr -> do {peekByteOff ptr 36 ::IO (FunPtr ((Ptr ()) -> (IO CInt)))}) raw >>= freeHaskellFunPtr
(\ptr -> do {peekByteOff ptr 40 ::IO (FunPtr ((Ptr ()) -> (IO CInt)))}) raw >>= freeHaskellFunPtr
foreign import ccall "yajl/yajl_parse.h &yajl_free"
cParserFree :: FunPtr (Ptr ParserHandle -> IO ())
type Callback0 = Ptr () -> IO CInt
type CallbackBool = Ptr () -> CInt -> IO CInt
type CallbackNum = Ptr () -> Ptr CChar -> CUInt -> IO CInt
type CallbackText = Ptr () -> Ptr CUChar -> CUInt -> IO CInt
catchRef :: I.IORef (Maybe E.SomeException) -> IO Bool -> IO CInt
catchRef ref io = do
continue <- E.catch io $ \e -> do
I.writeIORef ref $ Just e
return False
return $ cFromBool continue
wrapCallback0 :: I.IORef (Maybe E.SomeException) -> IO Bool -> IO (FunPtr Callback0)
wrapCallback0 ref io = allocCallback0 $ \_ -> catchRef ref io
wrapCallbackBool :: I.IORef (Maybe E.SomeException) -> (Bool -> IO Bool) -> IO (FunPtr CallbackBool)
wrapCallbackBool ref io = allocCallbackBool $ \_ -> catchRef ref . io . cToBool
wrapCallbackNum :: I.IORef (Maybe E.SomeException) -> (B.ByteString -> IO Bool) -> IO (FunPtr CallbackNum)
wrapCallbackNum ref io = allocCallbackNum $ \_ cstr len -> catchRef ref $
B.packCStringLen (cstr, fromIntegral len) >>= io
wrapCallbackText :: I.IORef (Maybe E.SomeException) -> (T.Text -> IO Bool) -> IO (FunPtr CallbackText)
wrapCallbackText ref io = allocCallbackText $ \_ cstr len -> catchRef ref $ do
bytes <- BU.unsafePackCStringLen (castPtr cstr, fromIntegral len)
io (TE.decodeUtf8 bytes)
foreign import ccall "wrapper"
allocCallback0 :: Callback0 -> IO (FunPtr Callback0)
foreign import ccall "wrapper"
allocCallbackBool :: CallbackBool -> IO (FunPtr CallbackBool)
foreign import ccall "wrapper"
allocCallbackNum :: CallbackNum -> IO (FunPtr CallbackNum)
foreign import ccall "wrapper"
allocCallbackText :: CallbackText -> IO (FunPtr CallbackText)
withParser :: Parser -> (ParserHandle -> IO a) -> IO a
withParser p io = withForeignPtr (parserHandle p) $ io . ParserHandle
parseUTF8 :: Parser -> B.ByteString -> IO ParseStatus
parseUTF8 p bytes =
withParser p $ \handle ->
BU.unsafeUseAsCStringLen bytes $ \(cstr, len) ->
yajl_parse handle (castPtr cstr) (fromIntegral len)
>>= checkParseStatus p
parseText :: Parser -> T.Text -> IO ParseStatus
parseText p text =
withParser p $ \handle ->
withUtf8 text $ \(utf8, len) ->
yajl_parse handle utf8 len
>>= checkParseStatus p
parseComplete :: Parser -> IO ParseStatus
parseComplete p =
withParser p $ \handle ->
yajl_parse_complete handle
>>= checkParseStatus p
getBytesConsumed :: Parser -> IO (Integer)
getBytesConsumed a1 =
withParser a1 $ \a1' ->
getBytesConsumed'_ a1' >>= \res ->
let {res' = toInteger res} in
return (res')
data RawParseStatus = YajlStatusOk
| YajlStatusClientCanceled
| YajlStatusInsufficientData
| YajlStatusError
deriving (Enum)
checkParseStatus :: Parser -> CInt -> IO ParseStatus
checkParseStatus p int = case toEnum $ fromIntegral int of
YajlStatusOk -> return ParseFinished
YajlStatusClientCanceled -> do
threw <- I.readIORef $ parserErrorRef p
case threw of
Nothing -> return ParseCancelled
Just exc -> do
I.writeIORef (parserErrorRef p) Nothing
E.throwIO exc
YajlStatusInsufficientData -> return ParseContinue
YajlStatusError -> ParseError `fmap` getParseError p
getParseError :: Parser -> IO T.Text
getParseError p = withParser p $ \handle -> E.bracket
(yajl_get_error handle 0 nullPtr 0)
(yajl_free_error handle)
(\bytes -> T.pack `fmap` peekCString (castPtr bytes))
data Generator = Generator
{ genHandle :: ForeignPtr GenHandle
, genIndent :: ForeignPtr CChar
}
data GeneratorConfig = GeneratorConfig
{ generatorBeautify :: Bool
, generatorIndent :: T.Text
}
data GeneratorError
= InvalidAttributeName
| MaximumDepthExceeded
| GeneratorInErrorState
| GenerationComplete
| InvalidNumber
| NoBuffer
deriving (Show, Eq, Typeable)
instance E.Exception GeneratorError
newtype GenHandle = GenHandle (Ptr (GenHandle))
newtype GenConfig = GenConfig (Ptr (GenConfig))
newGenerator :: GeneratorConfig -> IO Generator
newGenerator config = allocaBytes 8 $ \cConfig -> do
cIndent <- marshalText $ generatorIndent config
(\ptr val -> do {pokeByteOff ptr 0 (val::CUInt)}) cConfig 0
withForeignPtr cIndent $ (\ptr val -> do {pokeByteOff ptr 4 (val::(Ptr CChar))}) cConfig
GenHandle handlePtr <- cGenAlloc (GenConfig cConfig) nullPtr
handleFP <- newForeignPtr cGenFree handlePtr
return $ Generator handleFP cIndent
marshalText :: T.Text -> IO (ForeignPtr CChar)
marshalText text =
BU.unsafeUseAsCStringLen (TE.encodeUtf8 text) $ \(temp, len) ->
mallocForeignPtrBytes (len + 1) >>= \fp ->
withForeignPtr fp $ \array -> do
copyArray array temp len
poke (advancePtr array len) 0
return fp
cGenAlloc :: GenConfig -> Ptr () -> IO (GenHandle)
cGenAlloc a1 a2 =
let {a1' = id a1} in
let {a2' = id a2} in
cGenAlloc'_ a1' a2' >>= \res ->
let {res' = id res} in
return (res')
foreign import ccall "yajl/yajl_gen.h &yajl_gen_free"
cGenFree :: FunPtr (Ptr GenHandle -> IO ())
withGenerator :: Generator -> (GenHandle -> IO a) -> IO a
withGenerator gen io = withForeignPtr (genHandle gen) $ io . GenHandle
getBuffer :: Generator -> IO B.ByteString
getBuffer gen =
withGenerator gen $ \handle ->
alloca $ \bufPtr ->
alloca $ \lenPtr -> do
yajl_gen_get_buf handle bufPtr lenPtr
buf <- peek bufPtr
len <- peek lenPtr
B.packCStringLen (castPtr buf, fromIntegral len)
clearBuffer :: Generator -> IO (())
clearBuffer a1 =
withGenerator a1 $ \a1' ->
clearBuffer'_ a1' >>= \res ->
let {res' = id res} in
return (res')
generateNull :: Generator -> IO (())
generateNull a1 =
withGenerator a1 $ \a1' ->
generateNull'_ a1' >>= \res ->
checkGenStatus res >>= \res' ->
return (res')
generateBoolean :: Generator -> Bool -> IO (())
generateBoolean a1 a2 =
withGenerator a1 $ \a1' ->
let {a2' = cFromBool a2} in
generateBoolean'_ a1' a2' >>= \res ->
checkGenStatus res >>= \res' ->
return (res')
generateIntegral :: Integral a => Generator -> a -> IO ()
generateIntegral gen = generateNumber gen . showBytes . toInteger
generateDouble :: Generator -> Double -> IO ()
generateDouble gen = generateNumber gen . showBytes
generateNumber :: Generator -> B.ByteString -> IO ()
generateNumber gen bytes =
withGenerator gen $ \handle ->
BU.unsafeUseAsCStringLen bytes $ \(cstr, len) ->
yajl_gen_number handle (castPtr cstr) (fromIntegral len)
>>= checkGenStatus
generateText :: Generator -> T.Text -> IO (())
generateText a1 a2 =
withGenerator a1 $ \a1' ->
withUtf8 a2 $ \(a2'1, a2'2) ->
generateText'_ a1' a2'1 a2'2 >>= \res ->
checkGenStatus res >>= \res' ->
return (res')
generateBeginArray :: Generator -> IO (())
generateBeginArray a1 =
withGenerator a1 $ \a1' ->
generateBeginArray'_ a1' >>= \res ->
checkGenStatus res >>= \res' ->
return (res')
generateEndArray :: Generator -> IO (())
generateEndArray a1 =
withGenerator a1 $ \a1' ->
generateEndArray'_ a1' >>= \res ->
checkGenStatus res >>= \res' ->
return (res')
generateBeginObject :: Generator -> IO (())
generateBeginObject a1 =
withGenerator a1 $ \a1' ->
generateBeginObject'_ a1' >>= \res ->
checkGenStatus res >>= \res' ->
return (res')
generateEndObject :: Generator -> IO (())
generateEndObject a1 =
withGenerator a1 $ \a1' ->
generateEndObject'_ a1' >>= \res ->
checkGenStatus res >>= \res' ->
return (res')
data GenStatus = YajlGenStatusOk
| YajlGenKeysMustBeStrings
| YajlMaxDepthExceeded
| YajlGenInErrorState
| YajlGenGenerationComplete
| YajlGenInvalidNumber
| YajlGenNoBuf
instance Enum GenStatus where
fromEnum YajlGenStatusOk = 0
fromEnum YajlGenKeysMustBeStrings = 1
fromEnum YajlMaxDepthExceeded = 2
fromEnum YajlGenInErrorState = 3
fromEnum YajlGenGenerationComplete = 4
fromEnum YajlGenInvalidNumber = 5
fromEnum YajlGenNoBuf = 6
toEnum 0 = YajlGenStatusOk
toEnum 1 = YajlGenKeysMustBeStrings
toEnum 2 = YajlMaxDepthExceeded
toEnum 3 = YajlGenInErrorState
toEnum 4 = YajlGenGenerationComplete
toEnum 5 = YajlGenInvalidNumber
toEnum 6 = YajlGenNoBuf
toEnum unmatched = error ("GenStatus.toEnum: Cannot match " ++ show unmatched)
checkGenStatus :: CInt -> IO ()
checkGenStatus int = case toEnum $ fromIntegral int of
YajlGenStatusOk -> return ()
YajlGenKeysMustBeStrings -> E.throwIO InvalidAttributeName
YajlMaxDepthExceeded -> E.throwIO MaximumDepthExceeded
YajlGenInErrorState -> E.throwIO GeneratorInErrorState
YajlGenGenerationComplete -> E.throwIO GenerationComplete
YajlGenInvalidNumber -> E.throwIO InvalidNumber
YajlGenNoBuf -> E.throwIO NoBuffer
cFromBool :: Bool -> CInt
cFromBool True = 1
cFromBool False = 0
cToBool :: CInt -> Bool
cToBool 1 = True
cToBool 0 = False
cToBool x = error $ "cToBool " ++ show x
withUtf8 :: T.Text -> ((Ptr CUChar, CUInt) -> IO a) -> IO a
withUtf8 text io =
let bytes = TE.encodeUtf8 text in
BU.unsafeUseAsCStringLen bytes $ \(cstr, len) ->
io (castPtr cstr, fromIntegral len)
showBytes :: Show a => a -> B.ByteString
showBytes = BC.pack . show
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_alloc"
yajl_alloc :: ((Ptr ()) -> ((Ptr ()) -> ((Ptr ()) -> ((Ptr ()) -> (IO (ParserHandle))))))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_parse"
yajl_parse :: ((ParserHandle) -> ((Ptr CUChar) -> (CUInt -> (IO CInt))))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_parse_complete"
yajl_parse_complete :: ((ParserHandle) -> (IO CInt))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_get_bytes_consumed"
getBytesConsumed'_ :: ((ParserHandle) -> (IO CUInt))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_get_error"
yajl_get_error :: ((ParserHandle) -> (CInt -> ((Ptr CUChar) -> (CUInt -> (IO (Ptr CUChar))))))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_free_error"
yajl_free_error :: ((ParserHandle) -> ((Ptr CUChar) -> (IO ())))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_alloc"
cGenAlloc'_ :: ((GenConfig) -> ((Ptr ()) -> (IO (GenHandle))))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_get_buf"
yajl_gen_get_buf :: ((GenHandle) -> ((Ptr (Ptr CUChar)) -> ((Ptr CUInt) -> (IO CInt))))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_clear"
clearBuffer'_ :: ((GenHandle) -> (IO ()))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_null"
generateNull'_ :: ((GenHandle) -> (IO CInt))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_bool"
generateBoolean'_ :: ((GenHandle) -> (CInt -> (IO CInt)))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_number"
yajl_gen_number :: ((GenHandle) -> ((Ptr CChar) -> (CUInt -> (IO CInt))))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_string"
generateText'_ :: ((GenHandle) -> ((Ptr CUChar) -> (CUInt -> (IO CInt))))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_array_open"
generateBeginArray'_ :: ((GenHandle) -> (IO CInt))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_array_close"
generateEndArray'_ :: ((GenHandle) -> (IO CInt))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_map_open"
generateBeginObject'_ :: ((GenHandle) -> (IO CInt))
foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_map_close"
generateEndObject'_ :: ((GenHandle) -> (IO CInt))