1{-# LANGUAGE ForeignFunctionInterface #-} 2 3-- an example UCL FFI module: 4-- uses the Object Model from Messagepack to emit 5-- 6 7module Data.UCL ( unpack ) where 8import Foreign.C 9import Foreign.Ptr 10import System.IO.Unsafe ( unsafePerformIO ) 11import qualified Data.Text as T 12import qualified Data.Vector as V 13import qualified Data.MessagePack as MSG 14 15type ParserHandle = Ptr () 16type UCLObjectHandle = Ptr () 17type UCLIterHandle = Ptr () 18type UCLEmitterType = CInt 19type ErrorString = String 20 21 22foreign import ccall "ucl_parser_new" ucl_parser_new :: CInt -> ParserHandle 23foreign import ccall "ucl_parser_add_string" ucl_parser_add_string :: ParserHandle -> CString -> CUInt -> IO Bool 24foreign import ccall "ucl_parser_add_file" ucl_parser_add_file :: ParserHandle -> CString -> IO Bool 25foreign import ccall "ucl_parser_get_object" ucl_parser_get_object :: ParserHandle -> UCLObjectHandle 26foreign import ccall "ucl_parser_get_error" ucl_parser_get_error :: ParserHandle -> CString 27 28foreign import ccall "ucl_object_iterate_new" ucl_object_iterate_new :: UCLObjectHandle -> UCLIterHandle 29foreign import ccall "ucl_object_iterate_safe" ucl_object_iterate_safe :: UCLIterHandle -> Bool -> UCLObjectHandle 30foreign import ccall "ucl_object_type" ucl_object_type :: UCLObjectHandle -> CUInt 31foreign import ccall "ucl_object_key" ucl_object_key :: UCLObjectHandle -> CString 32foreign import ccall "ucl_object_toint" ucl_object_toint :: UCLObjectHandle -> CInt 33foreign import ccall "ucl_object_todouble" ucl_object_todouble :: UCLObjectHandle -> CDouble 34foreign import ccall "ucl_object_tostring" ucl_object_tostring :: UCLObjectHandle -> CString 35foreign import ccall "ucl_object_toboolean" ucl_object_toboolean :: UCLObjectHandle -> Bool 36 37foreign import ccall "ucl_object_emit" ucl_object_emit :: UCLObjectHandle -> UCLEmitterType -> CString 38foreign import ccall "ucl_object_emit_len" ucl_object_emit_len :: UCLObjectHandle -> UCLEmitterType -> Ptr CSize -> IO CString 39 40type UCL_TYPE = CUInt 41ucl_OBJECT :: UCL_TYPE 42ucl_OBJECT = 0 43ucl_ARRAY :: UCL_TYPE 44ucl_ARRAY = 1 45ucl_INT :: UCL_TYPE 46ucl_INT = 2 47ucl_FLOAT :: UCL_TYPE 48ucl_FLOAT = 3 49ucl_STRING :: UCL_TYPE 50ucl_STRING = 4 51ucl_BOOLEAN :: UCL_TYPE 52ucl_BOOLEAN = 5 53ucl_TIME :: UCL_TYPE 54ucl_TIME = 6 55ucl_USERDATA :: UCL_TYPE 56ucl_USERDATA = 7 57ucl_NULL :: UCL_TYPE 58ucl_NULL = 8 59 60ucl_emit_json :: UCLEmitterType 61ucl_emit_json = 0 62ucl_emit_json_compact :: UCLEmitterType 63ucl_emit_json_compact = 1 :: UCLEmitterType 64ucl_emit_msgpack :: UCLEmitterType 65ucl_emit_msgpack = 4 :: UCLEmitterType 66 67ucl_parser_parse_string_pure :: String -> Either UCLObjectHandle ErrorString 68ucl_parser_parse_string_pure s = unsafePerformIO $ do 69 cs <- newCString s 70 let p = ucl_parser_new 0x4 71 didParse <- ucl_parser_add_string p cs (toEnum $ length s) 72 if didParse 73 then return $ Left $ ucl_parser_get_object p 74 else Right <$> peekCString ( ucl_parser_get_error p) 75 76ucl_parser_add_file_pure :: String -> Either UCLObjectHandle ErrorString 77ucl_parser_add_file_pure s = unsafePerformIO $ do 78 cs <- newCString s 79 let p = ucl_parser_new 0x4 80 didParse <- ucl_parser_add_file p cs 81 if didParse 82 then return $ Left $ ucl_parser_get_object p 83 else Right <$> peekCString ( ucl_parser_get_error p) 84 85unpack :: MSG.MessagePack a => String -> Either a ErrorString 86unpack s = case ucl_parser_parse_string_pure s of 87 (Right err) -> Right err 88 (Left obj) -> case MSG.fromObject (ucl_to_msgpack_object obj) of 89 Nothing -> Right "MessagePack fromObject Error" 90 (Just a) -> Left a 91 92ucl_to_msgpack_object :: UCLObjectHandle -> MSG.Object 93ucl_to_msgpack_object o = toMsgPackObj (ucl_object_type o) o 94 where 95 toMsgPackObj n obj 96 |n==ucl_OBJECT = MSG.ObjectMap $ uclObjectToVector obj 97 |n==ucl_ARRAY = MSG.ObjectArray undefined 98 |n==ucl_INT = MSG.ObjectInt $ fromEnum $ ucl_object_toint obj 99 |n==ucl_FLOAT = MSG.ObjectDouble $ realToFrac $ ucl_object_todouble obj 100 |n==ucl_STRING = MSG.ObjectStr $ T.pack $ unsafePerformIO $ peekCString $ ucl_object_tostring obj 101 |n==ucl_BOOLEAN = MSG.ObjectBool $ ucl_object_toboolean obj 102 |n==ucl_TIME = error "time undefined" 103 |n==ucl_USERDATA = error "userdata undefined" 104 |n==ucl_NULL = error "null undefined" 105 |otherwise = error "\"Unknown Type\" Error" 106 107uclObjectToVector :: UCLObjectHandle -> V.Vector (MSG.Object,MSG.Object) 108uclObjectToVector o = iterateObject (ucl_object_iterate_safe iter True ) iter V.empty 109 where 110 iter = ucl_object_iterate_new o 111 iterateObject obj it vec = if ucl_object_type obj == ucl_NULL 112 then vec 113 else iterateObject (ucl_object_iterate_safe it True) it (V.snoc vec ( getUclKey obj , ucl_to_msgpack_object obj)) 114 getUclKey obj = MSG.ObjectStr $ T.pack $ unsafePerformIO $ peekCString $ ucl_object_key obj 115 116uclArrayToVector :: UCLObjectHandle -> V.Vector MSG.Object 117uclArrayToVector o = iterateArray (ucl_object_iterate_safe iter True ) iter V.empty 118 where 119 iter = ucl_object_iterate_new o 120 iterateArray obj it vec = if ucl_object_type obj == ucl_NULL 121 then vec 122 else iterateArray (ucl_object_iterate_safe it True) it (V.snoc vec (ucl_to_msgpack_object obj)) 123 124