1306542Sbapt{-# LANGUAGE ForeignFunctionInterface #-} 2306542Sbapt 3306542Sbapt-- an example UCL FFI module: 4306542Sbapt-- uses the Object Model from Messagepack to emit 5306542Sbapt-- 6306542Sbapt 7306542Sbaptmodule Data.UCL ( unpack ) where 8306542Sbaptimport Foreign.C 9306542Sbaptimport Foreign.Ptr 10306542Sbaptimport System.IO.Unsafe ( unsafePerformIO ) 11306542Sbaptimport qualified Data.Text as T 12306542Sbaptimport qualified Data.Vector as V 13306542Sbaptimport qualified Data.MessagePack as MSG 14306542Sbapt 15306542Sbapttype ParserHandle = Ptr () 16306542Sbapttype UCLObjectHandle = Ptr () 17306542Sbapttype UCLIterHandle = Ptr () 18306542Sbapttype UCLEmitterType = CInt 19306542Sbapttype ErrorString = String 20306542Sbapt 21306542Sbapt 22306542Sbaptforeign import ccall "ucl_parser_new" ucl_parser_new :: CInt -> ParserHandle 23306542Sbaptforeign import ccall "ucl_parser_add_string" ucl_parser_add_string :: ParserHandle -> CString -> CUInt -> IO Bool 24306542Sbaptforeign import ccall "ucl_parser_add_file" ucl_parser_add_file :: ParserHandle -> CString -> IO Bool 25306542Sbaptforeign import ccall "ucl_parser_get_object" ucl_parser_get_object :: ParserHandle -> UCLObjectHandle 26306542Sbaptforeign import ccall "ucl_parser_get_error" ucl_parser_get_error :: ParserHandle -> CString 27306542Sbapt 28306542Sbaptforeign import ccall "ucl_object_iterate_new" ucl_object_iterate_new :: UCLObjectHandle -> UCLIterHandle 29306542Sbaptforeign import ccall "ucl_object_iterate_safe" ucl_object_iterate_safe :: UCLIterHandle -> Bool -> UCLObjectHandle 30306542Sbaptforeign import ccall "ucl_object_type" ucl_object_type :: UCLObjectHandle -> CUInt 31306542Sbaptforeign import ccall "ucl_object_key" ucl_object_key :: UCLObjectHandle -> CString 32306542Sbaptforeign import ccall "ucl_object_toint" ucl_object_toint :: UCLObjectHandle -> CInt 33306542Sbaptforeign import ccall "ucl_object_todouble" ucl_object_todouble :: UCLObjectHandle -> CDouble 34306542Sbaptforeign import ccall "ucl_object_tostring" ucl_object_tostring :: UCLObjectHandle -> CString 35306542Sbaptforeign import ccall "ucl_object_toboolean" ucl_object_toboolean :: UCLObjectHandle -> Bool 36306542Sbapt 37306542Sbaptforeign import ccall "ucl_object_emit" ucl_object_emit :: UCLObjectHandle -> UCLEmitterType -> CString 38306542Sbaptforeign import ccall "ucl_object_emit_len" ucl_object_emit_len :: UCLObjectHandle -> UCLEmitterType -> Ptr CSize -> IO CString 39306542Sbapt 40306542Sbapttype UCL_TYPE = CUInt 41306542Sbaptucl_OBJECT :: UCL_TYPE 42306542Sbaptucl_OBJECT = 0 43306542Sbaptucl_ARRAY :: UCL_TYPE 44306542Sbaptucl_ARRAY = 1 45306542Sbaptucl_INT :: UCL_TYPE 46306542Sbaptucl_INT = 2 47306542Sbaptucl_FLOAT :: UCL_TYPE 48306542Sbaptucl_FLOAT = 3 49306542Sbaptucl_STRING :: UCL_TYPE 50306542Sbaptucl_STRING = 4 51306542Sbaptucl_BOOLEAN :: UCL_TYPE 52306542Sbaptucl_BOOLEAN = 5 53306542Sbaptucl_TIME :: UCL_TYPE 54306542Sbaptucl_TIME = 6 55306542Sbaptucl_USERDATA :: UCL_TYPE 56306542Sbaptucl_USERDATA = 7 57306542Sbaptucl_NULL :: UCL_TYPE 58306542Sbaptucl_NULL = 8 59306542Sbapt 60306542Sbaptucl_emit_json :: UCLEmitterType 61306542Sbaptucl_emit_json = 0 62306542Sbaptucl_emit_json_compact :: UCLEmitterType 63306542Sbaptucl_emit_json_compact = 1 :: UCLEmitterType 64306542Sbaptucl_emit_msgpack :: UCLEmitterType 65306542Sbaptucl_emit_msgpack = 4 :: UCLEmitterType 66306542Sbapt 67306542Sbaptucl_parser_parse_string_pure :: String -> Either UCLObjectHandle ErrorString 68306542Sbaptucl_parser_parse_string_pure s = unsafePerformIO $ do 69306542Sbapt cs <- newCString s 70306542Sbapt let p = ucl_parser_new 0x4 71306542Sbapt didParse <- ucl_parser_add_string p cs (toEnum $ length s) 72306542Sbapt if didParse 73306542Sbapt then return $ Left $ ucl_parser_get_object p 74306542Sbapt else Right <$> peekCString ( ucl_parser_get_error p) 75306542Sbapt 76306542Sbaptucl_parser_add_file_pure :: String -> Either UCLObjectHandle ErrorString 77306542Sbaptucl_parser_add_file_pure s = unsafePerformIO $ do 78306542Sbapt cs <- newCString s 79306542Sbapt let p = ucl_parser_new 0x4 80306542Sbapt didParse <- ucl_parser_add_file p cs 81306542Sbapt if didParse 82306542Sbapt then return $ Left $ ucl_parser_get_object p 83306542Sbapt else Right <$> peekCString ( ucl_parser_get_error p) 84306542Sbapt 85306542Sbaptunpack :: MSG.MessagePack a => String -> Either a ErrorString 86306542Sbaptunpack s = case ucl_parser_parse_string_pure s of 87306542Sbapt (Right err) -> Right err 88306542Sbapt (Left obj) -> case MSG.fromObject (ucl_to_msgpack_object obj) of 89306542Sbapt Nothing -> Right "MessagePack fromObject Error" 90306542Sbapt (Just a) -> Left a 91306542Sbapt 92306542Sbaptucl_to_msgpack_object :: UCLObjectHandle -> MSG.Object 93306542Sbaptucl_to_msgpack_object o = toMsgPackObj (ucl_object_type o) o 94306542Sbapt where 95306542Sbapt toMsgPackObj n obj 96306542Sbapt |n==ucl_OBJECT = MSG.ObjectMap $ uclObjectToVector obj 97306542Sbapt |n==ucl_ARRAY = MSG.ObjectArray undefined 98306542Sbapt |n==ucl_INT = MSG.ObjectInt $ fromEnum $ ucl_object_toint obj 99306542Sbapt |n==ucl_FLOAT = MSG.ObjectDouble $ realToFrac $ ucl_object_todouble obj 100306542Sbapt |n==ucl_STRING = MSG.ObjectStr $ T.pack $ unsafePerformIO $ peekCString $ ucl_object_tostring obj 101306542Sbapt |n==ucl_BOOLEAN = MSG.ObjectBool $ ucl_object_toboolean obj 102306542Sbapt |n==ucl_TIME = error "time undefined" 103306542Sbapt |n==ucl_USERDATA = error "userdata undefined" 104306542Sbapt |n==ucl_NULL = error "null undefined" 105306542Sbapt |otherwise = error "\"Unknown Type\" Error" 106306542Sbapt 107306542SbaptuclObjectToVector :: UCLObjectHandle -> V.Vector (MSG.Object,MSG.Object) 108306542SbaptuclObjectToVector o = iterateObject (ucl_object_iterate_safe iter True ) iter V.empty 109306542Sbapt where 110306542Sbapt iter = ucl_object_iterate_new o 111306542Sbapt iterateObject obj it vec = if ucl_object_type obj == ucl_NULL 112306542Sbapt then vec 113306542Sbapt else iterateObject (ucl_object_iterate_safe it True) it (V.snoc vec ( getUclKey obj , ucl_to_msgpack_object obj)) 114306542Sbapt getUclKey obj = MSG.ObjectStr $ T.pack $ unsafePerformIO $ peekCString $ ucl_object_key obj 115306542Sbapt 116306542SbaptuclArrayToVector :: UCLObjectHandle -> V.Vector MSG.Object 117306542SbaptuclArrayToVector o = iterateArray (ucl_object_iterate_safe iter True ) iter V.empty 118306542Sbapt where 119306542Sbapt iter = ucl_object_iterate_new o 120306542Sbapt iterateArray obj it vec = if ucl_object_type obj == ucl_NULL 121306542Sbapt then vec 122306542Sbapt else iterateArray (ucl_object_iterate_safe it True) it (V.snoc vec (ucl_to_msgpack_object obj)) 123306542Sbapt 124