Skip to content

Commit 92c821b

Browse files
author
Tobias
committed
Haskell example
1 parent 20b1288 commit 92c821b

File tree

1 file changed

+123
-0
lines changed

1 file changed

+123
-0
lines changed

‎haskell/hucl.hs

+123
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,123 @@
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+

0 commit comments

Comments
 (0)