-- GENERATED by C->Haskell Compiler, version 0.16.0 Crystal Seed, 24 Jan 2009 (Haskell)
-- Edit the ORIGNAL .chs file instead!


{-# LINE 1 "./Text/JSON/YAJL.chs" #-}-- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
-- 
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Text.JSON.YAJL
	(
	-- * Parser
	  Parser
	, ParserCallbacks (..)
	, ParseStatus (..)
	, newParser
	, parseUTF8
	, parseText
	, parseComplete
	, getBytesConsumed
	
	-- * Generator
	, Generator
	, GeneratorConfig (..)
	, GeneratorError (..)
	, newGenerator
	, getBuffer
	, clearBuffer
	
	-- ** Generator events
	, generateNull
	, generateBoolean
	, generateIntegral
	, generateDouble
	, generateNumber
	, generateText
	, generateBeginArray
	, generateEndArray
	, generateBeginObject
	, generateEndObject
	) where
import qualified Control.Exception as E
import qualified Control.Monad.ST as ST
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 Data.STRef as ST
import qualified Foreign.Concurrent as FC

-- import unqualified for C2Hs
import Foreign
import Foreign.C


data Parser s = Parser
	{ parserHandle :: ForeignPtr ParserHandle
	, parserCallbacks :: ForeignPtr ()
	, parserErrorRef :: ST.STRef s (Maybe E.SomeException)
	}

-- | Each callback should return 'True' to continue parsing, or 'False'
-- to cancel.
--
data ParserCallbacks s = ParserCallbacks
	{ parsedNull :: ST.ST s Bool
	, parsedBoolean :: Bool -> ST.ST s Bool
	, parsedNumber :: B.ByteString -> ST.ST s Bool
	, parsedText :: T.Text -> ST.ST s Bool
	, parsedBeginArray :: ST.ST s Bool
	, parsedEndArray :: ST.ST s Bool
	, parsedBeginObject :: ST.ST s Bool
	, parsedAttributeName :: T.Text -> ST.ST s Bool
	, parsedEndObject :: ST.ST s Bool
	}

data ParseStatus
	= ParseFinished
	| ParseContinue
	-- ^ More input is required before parsing can complete.
	
	| ParseCancelled
	-- ^ A callback returned 'False'.
	
	| ParseError T.Text
	-- ^ An error occured while parsing. The included message contains
	-- details about the error.
	
	deriving (Show, Eq)

newtype ParserHandle = ParserHandle (Ptr (ParserHandle))
{-# LINE 103 "./Text/JSON/YAJL.chs" #-}

newParser :: ParserCallbacks s -> ST.ST s (Parser s)
newParser callbacks = do
	ref <- ST.newSTRef Nothing
	ST.unsafeIOToST $ do
		cCallbacks <- mallocForeignPtrBytes 44
{-# LINE 109 "./Text/JSON/YAJL.chs" #-}
		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
			
			-- Unused
			(\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 ())

-- Callback wrappers
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 :: ST.STRef s (Maybe E.SomeException) -> ST.ST s Bool -> IO CInt
catchRef ref st = do
	continue <- E.catch (E.unblock (ST.unsafeSTToIO st)) $ \e -> do
		ST.unsafeSTToIO $ ST.writeSTRef ref $ Just e
		return False
	return $ cFromBool continue

wrapCallback0 :: ST.STRef s (Maybe E.SomeException) -> ST.ST s Bool -> IO (FunPtr Callback0)
wrapCallback0 ref st = allocCallback0 $ \_ -> catchRef ref st

wrapCallbackBool :: ST.STRef s (Maybe E.SomeException) -> (Bool -> ST.ST s Bool) -> IO (FunPtr CallbackBool)
wrapCallbackBool ref st = allocCallbackBool $ \_ -> catchRef ref . st . cToBool

wrapCallbackNum :: ST.STRef s (Maybe E.SomeException) -> (B.ByteString -> ST.ST s Bool) -> IO (FunPtr CallbackNum)
wrapCallbackNum ref st = allocCallbackNum $ \_ cstr len -> catchRef ref $ do
	bytes <- ST.unsafeIOToST $ B.packCStringLen (cstr, fromIntegral len)
	st bytes

wrapCallbackText :: ST.STRef s (Maybe E.SomeException) -> (T.Text -> ST.ST s Bool) -> IO (FunPtr CallbackText)
wrapCallbackText ref st = allocCallbackText $ \_ cstr len -> catchRef ref $ do
	bytes <- ST.unsafeIOToST $ BU.unsafePackCStringLen (castPtr cstr, fromIntegral len)
	st (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 s -> (ParserHandle -> IO a) -> ST.ST s a
withParser p io = ST.unsafeIOToST $ withForeignPtr (parserHandle p) $ io . ParserHandle

parseUTF8 :: Parser s -> B.ByteString -> ST.ST s ParseStatus
parseUTF8 p bytes = parse' p $ \h ->
	BU.unsafeUseAsCStringLen bytes $ \(cstr, len) ->
	yajl_parse h (castPtr cstr) (fromIntegral len)

parseText :: Parser s -> T.Text -> ST.ST s ParseStatus
parseText p text = parse' p $ \h ->
	withUtf8 text $ \(utf8, len) ->
	yajl_parse h utf8 len

-- | Indicate that no more input is available, and parse any remaining
-- buffered input.
-- 
parseComplete :: Parser s -> ST.ST s ParseStatus
parseComplete p = parse' p yajl_parse_complete
{-# LINE 214 "./Text/JSON/YAJL.chs" #-}

parse' :: Parser s -> (ParserHandle -> IO CInt) -> ST.ST s ParseStatus
parse' p io = do
	ST.writeSTRef (parserErrorRef p) Nothing
	rc <- blockST $ withParser p io
	ST.unsafeIOToST $ touchForeignPtr $ parserCallbacks p
	case rc of
		0 -> return ParseFinished
		1 -> do
			threw <- ST.readSTRef $ parserErrorRef p
			case threw of
				Nothing -> return ParseCancelled
				Just exc -> throwST exc
		2 -> return ParseContinue
		3 -> ParseError `fmap` getParseError p
		_ -> return $ ParseError . T.pack $ "Unknown 'yajl_status': " ++ show rc

-- | Get the number of bytes consumed from the last input chunk.
-- 
-- Note that if using 'parseText', this corresponds to UTF-8 bytes,
-- /not/ characters.
-- 
-- If the most recent call to 'parseUTF8' or 'parseText' returned
-- 'ParseFinished', this will indicate whether there are any un-parsed
-- bytes past the end of input.
-- 
-- If the most recent parse returned 'ParseError', this will indicate where
-- the error occured.
-- 
getBytesConsumed :: Parser s -> ST.ST s Integer
getBytesConsumed p = withParser p $ \h ->
	toInteger `fmap` yajl_get_bytes_consumed h

getParseError :: Parser s -> ST.ST s T.Text
getParseError p = withParser p $ \h -> E.bracket
	(yajl_get_error h 0 nullPtr 0)
	(yajl_free_error h)
	(\bytes -> T.pack `fmap` peekCString (castPtr bytes))

data Generator s = Generator
	{ genHandle :: ForeignPtr GenHandle
	}

data GeneratorConfig = GeneratorConfig
	{ generatorBeautify :: Bool
	-- ^ Whether to generate indented, whitespaced output.
	
	, generatorIndent :: T.Text
	-- ^ How much to indent beautified output by. This is only used
	-- if 'generatorBeautify' is 'True'.
	}

-- | If an error is encountered when generating data, a 'GeneratorError'
-- will be thrown.
-- 
-- With the exception of 'MaximumDepthExceeded', this is usually due to
-- incorrect use of the library.
-- 
data GeneratorError
	= InvalidAttributeName
	| MaximumDepthExceeded
	| GeneratorInErrorState
	| GenerationComplete
	| InvalidNumber
	| NoBuffer
	| UnknownError Integer
	deriving (Show, Eq, Typeable)

instance E.Exception GeneratorError

newtype GenHandle = GenHandle (Ptr (GenHandle))
{-# LINE 285 "./Text/JSON/YAJL.chs" #-}
newtype GenConfig = GenConfig (Ptr (GenConfig))
{-# LINE 286 "./Text/JSON/YAJL.chs" #-}

-- | Create a new, empty generator with the given configuration.
-- 
newGenerator :: GeneratorConfig -> ST.ST s (Generator s)
newGenerator config = ST.unsafeIOToST $
	allocaBytes 8 $ \cConfig -> do
		cIndent <- marshalText $ generatorIndent config
	
		(\ptr val -> do {pokeByteOff ptr 0 (val::CUInt)}) cConfig $ cFromBool $ generatorBeautify config
		withForeignPtr cIndent $ (\ptr val -> do {pokeByteOff ptr 4 (val::(Ptr CChar))}) cConfig
	
		GenHandle handlePtr <- cGenAlloc (GenConfig cConfig) nullPtr
		touchForeignPtr cIndent
		handleFP <- newForeignPtr cGenFree handlePtr
		return $ Generator handleFP

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')
{-# LINE 315 "./Text/JSON/YAJL.chs" #-}

foreign import ccall "yajl/yajl_gen.h &yajl_gen_free"
	cGenFree :: FunPtr (Ptr GenHandle -> IO ())

withGenerator :: Generator s -> (GenHandle -> IO a) -> ST.ST s a
withGenerator gen io = ST.unsafeIOToST $ withForeignPtr (genHandle gen) $ io . GenHandle

-- | Retrieve the @NUL@-terminated byte buffer.
-- 
getBuffer :: Generator s -> ST.ST s B.ByteString
getBuffer gen =
	withGenerator gen $ \h ->
	alloca $ \bufPtr ->
	alloca $ \lenPtr -> do
	yajl_gen_get_buf h bufPtr lenPtr
	buf <- peek bufPtr
	len <- peek lenPtr
	-- TODO: check that len is < (maxBound :: Int)
	B.packCStringLen (castPtr buf, fromIntegral len)

-- | Clear the generator's output buffer. This does not change the state
-- of the generator.
-- 
clearBuffer :: Generator s -> ST.ST s ()
clearBuffer g = withGenerator g yajl_gen_clear
{-# LINE 340 "./Text/JSON/YAJL.chs" #-}

generateNull :: Generator s -> ST.ST s ()
generateNull g = generate' g yajl_gen_null
{-# LINE 343 "./Text/JSON/YAJL.chs" #-}

generateBoolean :: Generator s -> Bool -> ST.ST s ()
generateBoolean g x = generate' g $ \h ->
	yajl_gen_bool h (cFromBool x)

generateIntegral :: Integral a => Generator s -> a -> ST.ST s ()
generateIntegral g = generateNumber g . showBytes . toInteger

generateDouble :: Generator s -> Double -> ST.ST s ()
generateDouble g = generateNumber g . showBytes

generateNumber :: Generator s -> B.ByteString -> ST.ST s ()
generateNumber g bytes = generate' g $ \h ->
	BU.unsafeUseAsCStringLen bytes $ \(cstr, len) ->
	yajl_gen_number h (castPtr cstr) (fromIntegral len)

generateText :: Generator s -> T.Text -> ST.ST s ()
generateText g text = generate' g $ \h ->
	withUtf8 text $ \(utf8, len) ->
	yajl_gen_string h utf8 len

generateBeginArray :: Generator s -> ST.ST s ()
generateBeginArray g = generate' g yajl_gen_array_open
{-# LINE 366 "./Text/JSON/YAJL.chs" #-}

generateEndArray :: Generator s -> ST.ST s ()
generateEndArray g = generate' g yajl_gen_array_close
{-# LINE 369 "./Text/JSON/YAJL.chs" #-}

generateBeginObject :: Generator s -> ST.ST s ()
generateBeginObject g = generate' g yajl_gen_map_open
{-# LINE 372 "./Text/JSON/YAJL.chs" #-}

generateEndObject :: Generator s -> ST.ST s ()
generateEndObject g = generate' g yajl_gen_map_close
{-# LINE 375 "./Text/JSON/YAJL.chs" #-}

generate' :: Generator s -> (GenHandle -> IO CInt) -> ST.ST s ()
generate' g io = withGenerator g io >>= \rc -> case rc of
	0 -> return ()
	1 -> throwST InvalidAttributeName
	2 -> throwST MaximumDepthExceeded
	3 -> throwST GeneratorInErrorState
	4 -> throwST GenerationComplete
	5 -> throwST InvalidNumber
	6 -> throwST NoBuffer
	_ -> throwST $ UnknownError $ toInteger rc

cFromBool :: Integral a => Bool -> a
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

throwST :: E.Exception e => e -> ST.ST s a
throwST = ST.unsafeIOToST . E.throwIO

blockST :: ST.ST s a -> ST.ST s a
blockST = ST.unsafeIOToST . E.block . ST.unsafeSTToIO

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"
  yajl_get_bytes_consumed :: ((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"
  yajl_gen_clear :: ((GenHandle) -> (IO ()))

foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_null"
  yajl_gen_null :: ((GenHandle) -> (IO CInt))

foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_bool"
  yajl_gen_bool :: ((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"
  yajl_gen_string :: ((GenHandle) -> ((Ptr CUChar) -> (CUInt -> (IO CInt))))

foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_array_open"
  yajl_gen_array_open :: ((GenHandle) -> (IO CInt))

foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_array_close"
  yajl_gen_array_close :: ((GenHandle) -> (IO CInt))

foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_map_open"
  yajl_gen_map_open :: ((GenHandle) -> (IO CInt))

foreign import ccall safe "Text/JSON/YAJL.chs.h yajl_gen_map_close"
  yajl_gen_map_close :: ((GenHandle) -> (IO CInt))