124 lines
5.2 KiB
Haskell
124 lines
5.2 KiB
Haskell
{-# LANGUAGE ForeignFunctionInterface #-}
|
|
|
|
-- an example UCL FFI module:
|
|
-- uses the Object Model from Messagepack to emit
|
|
--
|
|
|
|
module Data.UCL ( unpack ) where
|
|
import Foreign.C
|
|
import Foreign.Ptr
|
|
import System.IO.Unsafe ( unsafePerformIO )
|
|
import qualified Data.Text as T
|
|
import qualified Data.Vector as V
|
|
import qualified Data.MessagePack as MSG
|
|
|
|
type ParserHandle = Ptr ()
|
|
type UCLObjectHandle = Ptr ()
|
|
type UCLIterHandle = Ptr ()
|
|
type UCLEmitterType = CInt
|
|
type ErrorString = String
|
|
|
|
|
|
foreign import ccall "ucl_parser_new" ucl_parser_new :: CInt -> ParserHandle
|
|
foreign import ccall "ucl_parser_add_string" ucl_parser_add_string :: ParserHandle -> CString -> CUInt -> IO Bool
|
|
foreign import ccall "ucl_parser_add_file" ucl_parser_add_file :: ParserHandle -> CString -> IO Bool
|
|
foreign import ccall "ucl_parser_get_object" ucl_parser_get_object :: ParserHandle -> UCLObjectHandle
|
|
foreign import ccall "ucl_parser_get_error" ucl_parser_get_error :: ParserHandle -> CString
|
|
|
|
foreign import ccall "ucl_object_iterate_new" ucl_object_iterate_new :: UCLObjectHandle -> UCLIterHandle
|
|
foreign import ccall "ucl_object_iterate_safe" ucl_object_iterate_safe :: UCLIterHandle -> Bool -> UCLObjectHandle
|
|
foreign import ccall "ucl_object_type" ucl_object_type :: UCLObjectHandle -> CUInt
|
|
foreign import ccall "ucl_object_key" ucl_object_key :: UCLObjectHandle -> CString
|
|
foreign import ccall "ucl_object_toint" ucl_object_toint :: UCLObjectHandle -> CInt
|
|
foreign import ccall "ucl_object_todouble" ucl_object_todouble :: UCLObjectHandle -> CDouble
|
|
foreign import ccall "ucl_object_tostring" ucl_object_tostring :: UCLObjectHandle -> CString
|
|
foreign import ccall "ucl_object_toboolean" ucl_object_toboolean :: UCLObjectHandle -> Bool
|
|
|
|
foreign import ccall "ucl_object_emit" ucl_object_emit :: UCLObjectHandle -> UCLEmitterType -> CString
|
|
foreign import ccall "ucl_object_emit_len" ucl_object_emit_len :: UCLObjectHandle -> UCLEmitterType -> Ptr CSize -> IO CString
|
|
|
|
type UCL_TYPE = CUInt
|
|
ucl_OBJECT :: UCL_TYPE
|
|
ucl_OBJECT = 0
|
|
ucl_ARRAY :: UCL_TYPE
|
|
ucl_ARRAY = 1
|
|
ucl_INT :: UCL_TYPE
|
|
ucl_INT = 2
|
|
ucl_FLOAT :: UCL_TYPE
|
|
ucl_FLOAT = 3
|
|
ucl_STRING :: UCL_TYPE
|
|
ucl_STRING = 4
|
|
ucl_BOOLEAN :: UCL_TYPE
|
|
ucl_BOOLEAN = 5
|
|
ucl_TIME :: UCL_TYPE
|
|
ucl_TIME = 6
|
|
ucl_USERDATA :: UCL_TYPE
|
|
ucl_USERDATA = 7
|
|
ucl_NULL :: UCL_TYPE
|
|
ucl_NULL = 8
|
|
|
|
ucl_emit_json :: UCLEmitterType
|
|
ucl_emit_json = 0
|
|
ucl_emit_json_compact :: UCLEmitterType
|
|
ucl_emit_json_compact = 1 :: UCLEmitterType
|
|
ucl_emit_msgpack :: UCLEmitterType
|
|
ucl_emit_msgpack = 4 :: UCLEmitterType
|
|
|
|
ucl_parser_parse_string_pure :: String -> Either UCLObjectHandle ErrorString
|
|
ucl_parser_parse_string_pure s = unsafePerformIO $ do
|
|
cs <- newCString s
|
|
let p = ucl_parser_new 0x4
|
|
didParse <- ucl_parser_add_string p cs (toEnum $ length s)
|
|
if didParse
|
|
then return $ Left $ ucl_parser_get_object p
|
|
else Right <$> peekCString ( ucl_parser_get_error p)
|
|
|
|
ucl_parser_add_file_pure :: String -> Either UCLObjectHandle ErrorString
|
|
ucl_parser_add_file_pure s = unsafePerformIO $ do
|
|
cs <- newCString s
|
|
let p = ucl_parser_new 0x4
|
|
didParse <- ucl_parser_add_file p cs
|
|
if didParse
|
|
then return $ Left $ ucl_parser_get_object p
|
|
else Right <$> peekCString ( ucl_parser_get_error p)
|
|
|
|
unpack :: MSG.MessagePack a => String -> Either a ErrorString
|
|
unpack s = case ucl_parser_parse_string_pure s of
|
|
(Right err) -> Right err
|
|
(Left obj) -> case MSG.fromObject (ucl_to_msgpack_object obj) of
|
|
Nothing -> Right "MessagePack fromObject Error"
|
|
(Just a) -> Left a
|
|
|
|
ucl_to_msgpack_object :: UCLObjectHandle -> MSG.Object
|
|
ucl_to_msgpack_object o = toMsgPackObj (ucl_object_type o) o
|
|
where
|
|
toMsgPackObj n obj
|
|
|n==ucl_OBJECT = MSG.ObjectMap $ uclObjectToVector obj
|
|
|n==ucl_ARRAY = MSG.ObjectArray undefined
|
|
|n==ucl_INT = MSG.ObjectInt $ fromEnum $ ucl_object_toint obj
|
|
|n==ucl_FLOAT = MSG.ObjectDouble $ realToFrac $ ucl_object_todouble obj
|
|
|n==ucl_STRING = MSG.ObjectStr $ T.pack $ unsafePerformIO $ peekCString $ ucl_object_tostring obj
|
|
|n==ucl_BOOLEAN = MSG.ObjectBool $ ucl_object_toboolean obj
|
|
|n==ucl_TIME = error "time undefined"
|
|
|n==ucl_USERDATA = error "userdata undefined"
|
|
|n==ucl_NULL = error "null undefined"
|
|
|otherwise = error "\"Unknown Type\" Error"
|
|
|
|
uclObjectToVector :: UCLObjectHandle -> V.Vector (MSG.Object,MSG.Object)
|
|
uclObjectToVector o = iterateObject (ucl_object_iterate_safe iter True ) iter V.empty
|
|
where
|
|
iter = ucl_object_iterate_new o
|
|
iterateObject obj it vec = if ucl_object_type obj == ucl_NULL
|
|
then vec
|
|
else iterateObject (ucl_object_iterate_safe it True) it (V.snoc vec ( getUclKey obj , ucl_to_msgpack_object obj))
|
|
getUclKey obj = MSG.ObjectStr $ T.pack $ unsafePerformIO $ peekCString $ ucl_object_key obj
|
|
|
|
uclArrayToVector :: UCLObjectHandle -> V.Vector MSG.Object
|
|
uclArrayToVector o = iterateArray (ucl_object_iterate_safe iter True ) iter V.empty
|
|
where
|
|
iter = ucl_object_iterate_new o
|
|
iterateArray obj it vec = if ucl_object_type obj == ucl_NULL
|
|
then vec
|
|
else iterateArray (ucl_object_iterate_safe it True) it (V.snoc vec (ucl_to_msgpack_object obj))
|
|
|