diff options
Diffstat (limited to 'contrib/libucl/haskell/hucl.hs')
| -rw-r--r-- | contrib/libucl/haskell/hucl.hs | 123 |
1 files changed, 0 insertions, 123 deletions
diff --git a/contrib/libucl/haskell/hucl.hs b/contrib/libucl/haskell/hucl.hs deleted file mode 100644 index 2dd3ac01e4c0..000000000000 --- a/contrib/libucl/haskell/hucl.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# 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)) - |