contrib/libucl/haskell/hucl.hs

   1 {-# LANGUAGE ForeignFunctionInterface #-}
   2
   3 -- an example UCL FFI module:
   4 -- uses the Object Model from Messagepack to emit
   5 --
   6
   7 module Data.UCL ( unpack ) where
   8 import Foreign.C
   9 import Foreign.Ptr
  10 import System.IO.Unsafe ( unsafePerformIO )
  11 import qualified Data.Text as T
  12 import qualified Data.Vector as V
  13 import qualified Data.MessagePack as MSG
  14
  15 type ParserHandle = Ptr ()
  16 type UCLObjectHandle = Ptr ()
  17 type UCLIterHandle = Ptr ()
  18 type UCLEmitterType = CInt
  19 type ErrorString = String
  20
  21
  22 foreign import ccall "ucl_parser_new" ucl_parser_new :: CInt -> ParserHandle
  23 foreign import ccall "ucl_parser_add_string" ucl_parser_add_string :: ParserHandle -> CString -> CUInt -> IO Bool
  24 foreign import ccall "ucl_parser_add_file" ucl_parser_add_file :: ParserHandle -> CString -> IO Bool
  25 foreign import ccall "ucl_parser_get_object" ucl_parser_get_object :: ParserHandle -> UCLObjectHandle
  26 foreign import ccall "ucl_parser_get_error" ucl_parser_get_error :: ParserHandle -> CString
  27
  28 foreign import ccall "ucl_object_iterate_new" ucl_object_iterate_new :: UCLObjectHandle -> UCLIterHandle
  29 foreign import ccall "ucl_object_iterate_safe" ucl_object_iterate_safe :: UCLIterHandle -> Bool -> UCLObjectHandle
  30 foreign import ccall "ucl_object_type" ucl_object_type :: UCLObjectHandle -> CUInt
  31 foreign import ccall "ucl_object_key" ucl_object_key :: UCLObjectHandle -> CString
  32 foreign import ccall "ucl_object_toint" ucl_object_toint :: UCLObjectHandle -> CInt
  33 foreign import ccall "ucl_object_todouble" ucl_object_todouble :: UCLObjectHandle -> CDouble
  34 foreign import ccall "ucl_object_tostring" ucl_object_tostring :: UCLObjectHandle -> CString
  35 foreign import ccall "ucl_object_toboolean" ucl_object_toboolean :: UCLObjectHandle -> Bool
  36
  37 foreign import ccall "ucl_object_emit" ucl_object_emit :: UCLObjectHandle -> UCLEmitterType -> CString
  38 foreign import ccall "ucl_object_emit_len" ucl_object_emit_len :: UCLObjectHandle -> UCLEmitterType -> Ptr CSize -> IO CString
  39
  40 type UCL_TYPE = CUInt
  41 ucl_OBJECT :: UCL_TYPE
  42 ucl_OBJECT = 0
  43 ucl_ARRAY :: UCL_TYPE
  44 ucl_ARRAY = 1
  45 ucl_INT :: UCL_TYPE
  46 ucl_INT = 2
  47 ucl_FLOAT :: UCL_TYPE
  48 ucl_FLOAT = 3
  49 ucl_STRING :: UCL_TYPE
  50 ucl_STRING = 4
  51 ucl_BOOLEAN :: UCL_TYPE
  52 ucl_BOOLEAN = 5
  53 ucl_TIME :: UCL_TYPE
  54 ucl_TIME = 6
  55 ucl_USERDATA :: UCL_TYPE
  56 ucl_USERDATA = 7
  57 ucl_NULL :: UCL_TYPE
  58 ucl_NULL = 8
  59
  60 ucl_emit_json           :: UCLEmitterType
  61 ucl_emit_json         = 0
  62 ucl_emit_json_compact   :: UCLEmitterType
  63 ucl_emit_json_compact = 1 :: UCLEmitterType
  64 ucl_emit_msgpack        :: UCLEmitterType
  65 ucl_emit_msgpack      = 4 :: UCLEmitterType
  66
  67 ucl_parser_parse_string_pure :: String -> Either UCLObjectHandle ErrorString
  68 ucl_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
  76 ucl_parser_add_file_pure :: String -> Either UCLObjectHandle ErrorString
  77 ucl_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
  85 unpack :: MSG.MessagePack a => String -> Either a ErrorString
  86 unpack 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
  92 ucl_to_msgpack_object :: UCLObjectHandle -> MSG.Object
  93 ucl_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
 107 uclObjectToVector :: UCLObjectHandle -> V.Vector (MSG.Object,MSG.Object)
 108 uclObjectToVector 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
 116 uclArrayToVector :: UCLObjectHandle -> V.Vector MSG.Object
 117 uclArrayToVector 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