003 File Manager
Current Path:
/usr/src/contrib/libucl/haskell
usr
/
src
/
contrib
/
libucl
/
haskell
/
📁
..
📄
hucl.hs
(5.21 KB)
Editing: hucl.hs
{-# 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))
Upload File
Create Folder