50a1eea · typeable/yaml

git.iko.soy/typeable/yaml

on master help sign in

Code cleanup, fixed withParser bug.

50a1eeaMichael Snoyman17 years ago

Text/Libyaml.chs+44−38

compare with master

unifiedsplit

@@ -1,5 +1,11 @@

1{-# LANGUAGE ForeignFunctionInterface #-}

2−module Text.Libyaml where

2+module Text.Libyaml

3+ ( Event (..)

4+ , parserParse

5+ , withParser

6+ , emitEvents

7+ , withEmitter

8+ ) where

4#include <yaml.h>

10#include <yaml.h>

5#include "../../../c/helper.h"

11#include "../../../c/helper.h"

@@ -26,15 +32,21 @@ eventSize = {#sizeof yaml_event_t#}

26 { id `Parser'

32 { id `Parser'

27 } -> `()' #}

33 } -> `()' #}

29−withParser :: (Parser -> IO a) -> IO a

35+withParser :: B.ByteString -> (Parser -> IO a) -> IO a

30−withParser f = do

36+withParser bs f = do

31− allocaBytes parserSize $ \p -> do

37+ allocaBytes parserSize $ \p ->

38+ do

32− let p' = Parser p

39+ let p' = Parser p

33− res <- yaml_parser_initialize p'

40+ _res <- yaml_parser_initialize p'

34− -- FIXME check res

41+ -- FIXME check res

42+ let (fptr, offset, len) = B.toForeignPtr bs

43+ ret <- withForeignPtr fptr $ \ptr ->

44+ do

45+ let ptr' = castPtr ptr `plusPtr` offset

46+ yaml_parser_set_input_string p' ptr' len

35− ret <- f p'

47+ f p'

36− yaml_parser_delete p'

48+ yaml_parser_delete p'

37− return ret

49+ return ret

39withEventRaw :: (EventRaw -> IO a) -> IO a

51withEventRaw :: (EventRaw -> IO a) -> IO a

40withEventRaw f = allocaBytes eventSize $ f . EventRaw

52withEventRaw f = allocaBytes eventSize $ f . EventRaw

@@ -45,14 +57,6 @@ withEventRaw f = allocaBytes eventSize $ f . EventRaw

45 , `Int'

57 , `Int'

46 } -> `()' #}

58 } -> `()' #}

48−parserSetInputString :: Parser -> B.ByteString -> IO ()

49−parserSetInputString parser bs = do

50− let (fptr, offset, len) = B.toForeignPtr bs

51− let fptr' = castForeignPtr fptr

52− withForeignPtr fptr' $ \ptr -> do

53− let ptr' = ptr `plusPtr` offset

54− yaml_parser_set_input_string parser ptr' len

55−

56{#fun unsafe yaml_parser_parse

60{#fun unsafe yaml_parser_parse

57 { id `Parser'

61 { id `Parser'

58 , id `EventRaw'

62 , id `EventRaw'

@@ -71,10 +75,15 @@ parserParse parser = do

71 rest <- parserParse parser

75 rest <- parserParse parser

72 return $! event : rest

76 return $! event : rest

78+{#fun unsafe print_parser_error

79+ { id `Parser'

80+ } -> `()' #}

81+

74parserParseOne :: Parser -> IO Event

82parserParseOne :: Parser -> IO Event

75parserParseOne parser = withEventRaw $ \er -> do

83parserParseOne parser = withEventRaw $ \er -> do

76 res <- yaml_parser_parse parser er

84 res <- yaml_parser_parse parser er

77− when (res == 0) $ fail $ "parserParse: " ++ show res

85+ when (res == 0) $

86+ print_parser_error parser >> fail "yaml_parser_parse failed"

78 event <- getEvent er

87 event <- getEvent er

79 yaml_event_delete er

88 yaml_event_delete er

80 return event

89 return event

@@ -95,8 +104,8 @@ data Event =

104

96{#enum yaml_event_type_e as EventType {underscoreToCase} deriving (Show) #}

105{#enum yaml_event_type_e as EventType {underscoreToCase} deriving (Show) #}

97getEvent :: EventRaw -> IO Event

106getEvent :: EventRaw -> IO Event

98−getEvent (EventRaw ptr) = do

107+getEvent (EventRaw ptr') = do

99− et <- {#get yaml_event_t.type#} ptr

108+ et <- {#get yaml_event_t.type#} ptr'

100 case toEnum $ fromEnum et of

109 case toEnum $ fromEnum et of

101 YamlNoEvent -> return EventNone

110 YamlNoEvent -> return EventNone

102 YamlStreamStartEvent -> return EventStreamStart

111 YamlStreamStartEvent -> return EventStreamStart

@@ -105,8 +114,8 @@ getEvent (EventRaw ptr) = do

105 YamlDocumentEndEvent -> return EventDocumentEnd

114 YamlDocumentEndEvent -> return EventDocumentEnd

106 YamlAliasEvent -> return EventAlias

115 YamlAliasEvent -> return EventAlias

107 YamlScalarEvent -> do

116 YamlScalarEvent -> do

108− yvalue <- {#get yaml_event_t.data.scalar.value#} ptr

117+ yvalue <- {#get yaml_event_t.data.scalar.value#} ptr'

109− ylen <- {#get yaml_event_t.data.scalar.length#} ptr

118+ ylen <- {#get yaml_event_t.data.scalar.length#} ptr'

110 let yvalue' = castPtr yvalue

119 let yvalue' = castPtr yvalue

111 let ylen' = fromEnum ylen

120 let ylen' = fromEnum ylen

112 let ylen'' = toEnum $ fromEnum ylen

121 let ylen'' = toEnum $ fromEnum ylen

@@ -144,9 +153,9 @@ withBuffer f = do

144 let b' = Buffer b

153 let b' = Buffer b

145 buffer_init b'

154 buffer_init b'

146 f b'

155 f b'

147− ptr <- {#get buffer_t.buff#} b

156+ ptr' <- {#get buffer_t.buff#} b

148 len <- {#get buffer_t.used#} b

157 len <- {#get buffer_t.used#} b

149− fptr <- newForeignPtr_ $ castPtr ptr

158+ fptr <- newForeignPtr_ $ castPtr ptr'

150 return $! B.fromForeignPtr fptr 0 $ fromIntegral len

159 return $! B.fromForeignPtr fptr 0 $ fromIntegral len

151

160

152{#fun unsafe yaml_emitter_set_output

161{#fun unsafe yaml_emitter_set_output

@@ -162,7 +171,7 @@ withEmitter :: (Emitter -> IO ()) -> IO B.ByteString

162withEmitter f = do

171withEmitter f = do

163 allocaBytes emitterSize $ \e -> do

172 allocaBytes emitterSize $ \e -> do

164 let e' = Emitter e

173 let e' = Emitter e

165− res <- yaml_emitter_initialize e'

174+ _res <- yaml_emitter_initialize e'

166 -- FIXME check res

175 -- FIXME check res

167 bs <- withBuffer $ \(Buffer b) -> do

176 bs <- withBuffer $ \(Buffer b) -> do

168 let fun = buffer_append

177 let fun = buffer_append

@@ -181,23 +190,16 @@ withEmitter f = do

181 } -> `()' #}

190 } -> `()' #}

182

191

183emitEvents :: Emitter -> [Event] -> IO ()

192emitEvents :: Emitter -> [Event] -> IO ()

184−emitEvents emitter [] = return ()

193+emitEvents _ [] = return ()

185emitEvents emitter (e:rest) = do

194emitEvents emitter (e:rest) = do

186 res <- toEventRaw e $ yaml_emitter_emit emitter

195 res <- toEventRaw e $ yaml_emitter_emit emitter

187 when (res == 0) $

196 when (res == 0) $

188 print_emitter_error emitter >> fail "yaml_emitter_emit failed"

197 print_emitter_error emitter >> fail "yaml_emitter_emit failed"

189 emitEvents emitter rest

198 emitEvents emitter rest

190

199

191−{#enum yaml_encoding_e as YamlEncoding {underscoreToCase} deriving (Show) #}

192−{#enum yaml_scalar_style_e as ScalarStyle {underscoreToCase}

193− deriving (Show) #}

194−

195−enumToIntegral :: (Enum e, Integral i) => e -> i

196−enumToIntegral = fromIntegral . fromEnum

197−

198{#fun unsafe yaml_stream_start_event_initialize

200{#fun unsafe yaml_stream_start_event_initialize

199 { id `EventRaw'

201 { id `EventRaw'

200− , enumToIntegral `YamlEncoding'

202+ , `Int'

201 } -> `Int' #}

203 } -> `Int' #}

202

204

203{#fun unsafe yaml_stream_end_event_initialize

205{#fun unsafe yaml_stream_end_event_initialize

@@ -212,7 +214,7 @@ enumToIntegral = fromIntegral . fromEnum

212 , `Int'

214 , `Int'

213 , `Int'

215 , `Int'

214 , `Int'

216 , `Int'

215− , enumToIntegral `ScalarStyle'

217+ , `Int'

216 } -> `Int' #}

218 } -> `Int' #}

217

219

218{#fun unsafe simple_document_start

220{#fun unsafe simple_document_start

@@ -252,7 +254,9 @@ toEventRaw :: Event -> (EventRaw -> IO a) -> IO a

252toEventRaw e f = withEventRaw $ \er -> do

254toEventRaw e f = withEventRaw $ \er -> do

253 case e of

255 case e of

254 EventStreamStart ->

256 EventStreamStart ->

255− yaml_stream_start_event_initialize er YamlUtf8Encoding

257+ yaml_stream_start_event_initialize

258+ er

259+ 0 -- YAML_ANY_ENCODING

256 EventStreamEnd ->

260 EventStreamEnd ->

257 yaml_stream_end_event_initialize er

261 yaml_stream_end_event_initialize er

258 EventDocumentStart ->

262 EventDocumentStart ->

@@ -271,7 +275,7 @@ toEventRaw e f = withEventRaw $ \er -> do

271 len

275 len

272 0

276 0

273 1

277 1

274− YamlAnyScalarStyle

278+ 0 -- YAML_ANY_SCALAR_STYLE

275 EventSequenceStart ->

279 EventSequenceStart ->

276 yaml_sequence_start_event_initialize

280 yaml_sequence_start_event_initialize

277 er

281 er

@@ -290,4 +294,6 @@ toEventRaw e f = withEventRaw $ \er -> do

290 0 -- YAML_ANY_SEQUENCE_STYLE

294 0 -- YAML_ANY_SEQUENCE_STYLE

291 EventMappingEnd ->

295 EventMappingEnd ->

292 yaml_mapping_end_event_initialize er

296 yaml_mapping_end_event_initialize er

297+ EventAlias -> error "toEventRaw: EventAlias not supported"

298+ EventNone -> error "toEventRaw: EventNone not supported"

293 f er

299 f er

Text/Yaml.hs+24−15

@@ -20,31 +20,38 @@ module Text.Yaml

20 , decodeFile

21 ) where

23+import Prelude hiding (readList)

23import Text.Libyaml

24import Text.Libyaml

24import qualified Data.ByteString as B

25import qualified Data.ByteString as B

25import Data.ByteString.Class

26import Data.ByteString.Class

26import Data.Object

27import Data.Object

27import System.IO.Unsafe

28import System.IO.Unsafe

29−encodeFile :: IsObject o => FilePath -> o -> IO ()

30+encode :: (StrictByteString bs, ToObject o) => o -> bs

30−encodeFile path o = B.writeFile path $ encode o

31+encode = unsafePerformIO . encode'

32−decodeFile :: (Monad m, IsObject o) => FilePath -> IO (m o)

33+decode :: (Monad m, StrictByteString bs, FromObject o) => bs -> m o

33−decodeFile path = decode `fmap` B.readFile path

34+decode = unsafePerformIO . decode'

36+encodeFile :: ToObject o => FilePath -> o -> IO ()

37+encodeFile path o = encode' o >>= B.writeFile path

38+

39+decodeFile :: (Monad m, FromObject o) => FilePath -> IO (m o)

40+decodeFile path = do

41+ c <- B.readFile path

42+ decode' c

43+

35−encode :: (StrictByteString bs, IsObject o) => o -> bs

44+encode' :: (StrictByteString bs, ToObject o) => o -> IO bs

36−encode o =

45+encode' o =

37 let events = objectToEvents $ toObject o

46 let events = objectToEvents $ toObject o

38 result = withEmitter $ flip emitEvents $ events

47 result = withEmitter $ flip emitEvents $ events

39− in fromStrictByteString $ unsafePerformIO result

48+ in fromStrictByteString `fmap` result

41−decode :: (Monad m, StrictByteString bs, IsObject o) => bs -> m o

50+decode' :: (Monad m, StrictByteString bs, FromObject o) => bs -> IO (m o)

42−decode bs = do

51+decode' bs = do

43− let eventsIO = withParser $ \p -> do

52+ let bs' = toStrictByteString bs

44− parserSetInputString p $ toStrictByteString bs

45− parserParse p

53+ events = withParser bs' parserParse

46− events = unsafePerformIO eventsIO

47− fromObject $ eventsToObject events

54+ (fromObject . eventsToObject) `fmap` events

49objectToEvents :: Object -> [Event]

56objectToEvents :: Object -> [Event]

50objectToEvents y = concat

57objectToEvents y = concat

@@ -75,7 +82,7 @@ eventsToObject = fst . readSingle . dropWhile isIgnored where

75 readSingle (EventScalar bs:rest) = (Scalar bs, rest)

82 readSingle (EventScalar bs:rest) = (Scalar bs, rest)

76 readSingle (EventSequenceStart:rest) = readList [] rest

83 readSingle (EventSequenceStart:rest) = readList [] rest

77 readSingle (EventMappingStart:rest) = readMap [] rest

84 readSingle (EventMappingStart:rest) = readMap [] rest

78− readSingle (x:rest) = error $ "readSingle: " ++ show x

85+ readSingle (x:_) = error $ "readSingle: " ++ show x

79 readList :: [Object] -> [Event] -> (Object, [Event])

86 readList :: [Object] -> [Event] -> (Object, [Event])

80 readList nodes (EventSequenceEnd:rest) =

87 readList nodes (EventSequenceEnd:rest) =

81 (Sequence $ reverse nodes, rest)

88 (Sequence $ reverse nodes, rest)

@@ -87,3 +94,5 @@ eventsToObject = fst . readSingle . dropWhile isIgnored where

87 readMap pairs (EventScalar bs:events) =

94 readMap pairs (EventScalar bs:events) =

88 let (next, rest) = readSingle events

95 let (next, rest) = readSingle events

89 in readMap ((fromStrictByteString bs, next) : pairs) rest

96 in readMap ((fromStrictByteString bs, next) : pairs) rest

97+ readMap _ (e:_) = error $ "Unexpected event in readMap: " ++ show e

98+ readMap _ [] = error "Unexpected empty event list in readMap"

c/helper.c+8

@@ -31,6 +31,14 @@ int buffer_append(void *ext, unsigned char *str, size_t size)

31 return 1;

32}

34+void print_parser_error(yaml_parser_t *p)

35+{

36+ fprintf(stderr, "Problem: %s\nContext: %s\nOffset: %u\n",

37+ p->problem,

38+ p->context,

39+ (unsigned int) p->problem_offset);

40+}

41+

34void print_emitter_error(yaml_emitter_t *e)

42void print_emitter_error(yaml_emitter_t *e)

35{

43{

36 fprintf(stderr, "%s\n", e->problem);

44 fprintf(stderr, "%s\n", e->problem);

c/helper.h+1

@@ -10,6 +10,7 @@ typedef struct buffer_s {

10void buffer_init(buffer_t *buffer);

11int buffer_append(void *ext, unsigned char *str, size_t size);

13+void print_parser_error(yaml_parser_t *p);

13void print_emitter_error(yaml_emitter_t *e);

14void print_emitter_error(yaml_emitter_t *e);

14int simple_document_start(yaml_event_t *e);

15int simple_document_start(yaml_event_t *e);