50a1eea · typeable/yaml

git.iko.soy/typeable/yaml

Code cleanup, fixed withParser bug.

Was calling setInputString and then garbage collecting occassionally. Now have calls properly nested.

commit50a1eea4ebb0560ca2eb6aa7c254d5affe866704 authorMichael Snoyman <michael@snoyman.com> dateMon 27 Jul 2009, 21:21 (17 years ago) parentdc35629

4 files changed+77−53

compare with master

unifiedsplit

Text/Libyaml.chs+44−38 Text/Yaml.hs+24−15 c/helper.c+8 c/helper.h+1

Text/Libyaml.chs+44−38

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

11{-# LANGUAGE ForeignFunctionInterface #-}

2−module Text.Libyaml where

2+module Text.Libyaml

3+ ( Event (..)

4+ , parserParse

5+ , withParser

6+ , emitEvents

7+ , withEmitter

8+ ) where

410#include <yaml.h>

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

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

2632 { id `Parser'

2733 } -> `()' #}

2834

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

30−withParser f = do

31− allocaBytes parserSize $ \p -> do

32− let p' = Parser p

33− res <- yaml_parser_initialize p'

34− -- FIXME check res

35− ret <- f p'

36− yaml_parser_delete p'

37− return ret

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

36+withParser bs f = do

37+ allocaBytes parserSize $ \p ->

38+ do

39+ let p' = Parser p

40+ _res <- yaml_parser_initialize p'

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

47+ f p'

48+ yaml_parser_delete p'

49+ return ret

3850

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

4052withEventRaw f = allocaBytes eventSize $ f . EventRaw

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

4557 , `Int'

4658 } -> `()' #}

4759

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−

5660{#fun unsafe yaml_parser_parse

5761 { id `Parser'

5862 , id `EventRaw'

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

7175 rest <- parserParse parser

7276 return $! event : rest

7377

78+{#fun unsafe print_parser_error

79+ { id `Parser'

80+ } -> `()' #}

81+

7482parserParseOne :: Parser -> IO Event

7583parserParseOne parser = withEventRaw $ \er -> do

7684 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"

7887 event <- getEvent er

7988 yaml_event_delete er

8089 return event

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

95104

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

97106getEvent :: EventRaw -> IO Event

98−getEvent (EventRaw ptr) = do

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

107+getEvent (EventRaw ptr') = do

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

100109 case toEnum $ fromEnum et of

101110 YamlNoEvent -> return EventNone

102111 YamlStreamStartEvent -> return EventStreamStart

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

105114 YamlDocumentEndEvent -> return EventDocumentEnd

106115 YamlAliasEvent -> return EventAlias

107116 YamlScalarEvent -> do

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

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

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

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

110119 let yvalue' = castPtr yvalue

111120 let ylen' = fromEnum ylen

112121 let ylen'' = toEnum $ fromEnum ylen

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

144153 let b' = Buffer b

145154 buffer_init b'

146155 f b'

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

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

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

149− fptr <- newForeignPtr_ $ castPtr ptr

158+ fptr <- newForeignPtr_ $ castPtr ptr'

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

151160

152161{#fun unsafe yaml_emitter_set_output

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

162171withEmitter f = do

163172 allocaBytes emitterSize $ \e -> do

164173 let e' = Emitter e

165− res <- yaml_emitter_initialize e'

174+ _res <- yaml_emitter_initialize e'

166175 -- FIXME check res

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

168177 let fun = buffer_append

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

181190 } -> `()' #}

182191

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

184−emitEvents emitter [] = return ()

193+emitEvents _ [] = return ()

185194emitEvents emitter (e:rest) = do

186195 res <- toEventRaw e $ yaml_emitter_emit emitter

187196 when (res == 0) $

188197 print_emitter_error emitter >> fail "yaml_emitter_emit failed"

189198 emitEvents emitter rest

190199

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−

198200{#fun unsafe yaml_stream_start_event_initialize

199201 { id `EventRaw'

200− , enumToIntegral `YamlEncoding'

202+ , `Int'

201203 } -> `Int' #}

202204

203205{#fun unsafe yaml_stream_end_event_initialize

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

212214 , `Int'

213215 , `Int'

214216 , `Int'

215− , enumToIntegral `ScalarStyle'

217+ , `Int'

216218 } -> `Int' #}

217219

218220{#fun unsafe simple_document_start

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

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

253255 case e of

254256 EventStreamStart ->

255− yaml_stream_start_event_initialize er YamlUtf8Encoding

257+ yaml_stream_start_event_initialize

258+ er

259+ 0 -- YAML_ANY_ENCODING

256260 EventStreamEnd ->

257261 yaml_stream_end_event_initialize er

258262 EventDocumentStart ->

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

271275 len

272276 0

273277 1

274− YamlAnyScalarStyle

278+ 0 -- YAML_ANY_SCALAR_STYLE

275279 EventSequenceStart ->

276280 yaml_sequence_start_event_initialize

277281 er

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

290294 0 -- YAML_ANY_SEQUENCE_STYLE

291295 EventMappingEnd ->

292296 yaml_mapping_end_event_initialize er

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

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

293299 f er

Text/Yaml.hs+24−15

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

2020 , decodeFile

2121 ) where

2222

23+import Prelude hiding (readList)

2324import Text.Libyaml

2425import qualified Data.ByteString as B

2526import Data.ByteString.Class

2627import Data.Object

2728import System.IO.Unsafe

2829

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

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

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

31+encode = unsafePerformIO . encode'

3132

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

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

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

34+decode = unsafePerformIO . decode'

3435

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

36−encode o =

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+

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

45+encode' o =

3746 let events = objectToEvents $ toObject o

3847 result = withEmitter $ flip emitEvents $ events

39− in fromStrictByteString $ unsafePerformIO result

48+ in fromStrictByteString `fmap` result

4049

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

42−decode bs = do

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

44− parserSetInputString p $ toStrictByteString bs

45− parserParse p

46− events = unsafePerformIO eventsIO

47− fromObject $ eventsToObject events

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

51+decode' bs = do

52+ let bs' = toStrictByteString bs

53+ events = withParser bs' parserParse

54+ (fromObject . eventsToObject) `fmap` events

4855

4956objectToEvents :: Object -> [Event]

5057objectToEvents y = concat

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

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

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

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

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

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

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

8087 readList nodes (EventSequenceEnd:rest) =

8188 (Sequence $ reverse nodes, rest)

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

8794 readMap pairs (EventScalar bs:events) =

8895 let (next, rest) = readSingle events

8996 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)

3131 return 1;

3232}

3333

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+

3442void print_emitter_error(yaml_emitter_t *e)

3543{

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

c/helper.h+1

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

1010void buffer_init(buffer_t *buffer);

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

1212

13+void print_parser_error(yaml_parser_t *p);

1314void print_emitter_error(yaml_emitter_t *e);

1415int simple_document_start(yaml_event_t *e);

1516