b1694ae · typeable/yaml

git.iko.soy/typeable/yaml

on master help sign in

Migrate to conduit

b1694aeMichael Snoyman15 years ago

Text/Libyaml.hs+112−101

compare with master

unifiedsplit

@@ -41,8 +41,9 @@ import Control.Monad.IO.Class

41import Control.Monad.Trans.Class (lift)

43import Control.Exception (throwIO, Exception, finally)

44−import Data.Enumerator

45import Control.Applicative

44import Control.Applicative

45+import Control.Monad.Trans.Resource

46+import qualified Data.Conduit as C

47data Event =

48data Event =

48 EventStreamStart

49 EventStreamStart

@@ -120,8 +121,8 @@ eventSize = 104

120foreign import ccall unsafe "yaml_parser_initialize"

121foreign import ccall unsafe "yaml_parser_initialize"

121 c_yaml_parser_initialize :: Parser -> IO CInt

122 c_yaml_parser_initialize :: Parser -> IO CInt

122

123

123−foreign import ccall unsafe "&yaml_parser_delete"

124+foreign import ccall unsafe "yaml_parser_delete"

124− c_yaml_parser_delete :: FunPtr (Parser -> IO ())

125+ c_yaml_parser_delete :: Parser -> IO ()

125

126

126foreign import ccall unsafe "yaml_parser_set_input_string"

127foreign import ccall unsafe "yaml_parser_set_input_string"

127 c_yaml_parser_set_input_string :: Parser

128 c_yaml_parser_set_input_string :: Parser

@@ -146,8 +147,8 @@ foreign import ccall unsafe "fclose"

146 c_fclose :: File

147 c_fclose :: File

147 -> IO ()

148 -> IO ()

148

149

149−foreign import ccall unsafe "&fclose_helper"

150+foreign import ccall unsafe "fclose_helper"

150− c_fclose_helper :: FunPtr (File -> Parser -> IO ())

151+ c_fclose_helper :: File -> IO ()

151

152

152withForeignPtr' :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b

153withForeignPtr' :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b

153withForeignPtr' fp f = do

154withForeignPtr' fp f = do

@@ -455,60 +456,67 @@ newtype ToEventRawException = ToEventRawException CInt

455 deriving (Show, Typeable)

456 deriving (Show, Typeable)

456instance Exception ToEventRawException

457instance Exception ToEventRawException

457

458

458−decode :: MonadIO m => B.ByteString -> Enumerator Event m a

459+decode :: ResourceIO m => B.ByteString -> C.Source m Event

459−decode bs i = do

460+decode bs =

460− fp <- liftIO $ mallocForeignPtrBytes parserSize

461+ C.sourceIO alloc cleanup (runParser . fst)

461− res <- liftIO $ withForeignPtr fp c_yaml_parser_initialize

462+ where

462− liftIO $ addForeignPtrFinalizer c_yaml_parser_delete fp

463+ alloc = mask_ $ do

463− a <-

464+ ptr <- mallocBytes parserSize

465+ res <- c_yaml_parser_initialize ptr

464− if (res == 0)

466+ if res == 0

467+ then do

468+ c_yaml_parser_delete ptr

469+ free ptr

465− then throwError $ YamlException "Yaml out of memory"

470+ throwIO $ YamlException "Yaml out of memory"

466− else do -- NOTE: can't replace the following with unsafeUseAsCString

471+ else do

467− -- since it must run in a MonadIO

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

472+ let (bsfptr, offset, len) = B.toForeignPtr bs

469− withForeignPtr' fptr $ \ptr -> do

473+ let bsptrOrig = unsafeForeignPtrToPtr bsfptr

470− let ptr' = castPtr ptr `plusPtr` offset

474+ let bsptr = castPtr bsptrOrig `plusPtr` offset

471− len' = fromIntegral len

475+ c_yaml_parser_set_input_string ptr bsptr (fromIntegral len)

472− liftIO $ withForeignPtr fp $ \p ->

476+ return (ptr, bsfptr)

473− c_yaml_parser_set_input_string p ptr' len'

477+ cleanup (ptr, bsfptr) = do

474− runParser fp i

478+ touchForeignPtr bsfptr

475− return a

479+ c_yaml_parser_delete ptr

476−

480+ free ptr

481+

477−decodeFile :: MonadIO m => FilePath -> Enumerator Event m a

482+decodeFile :: ResourceIO m => FilePath -> C.Source m Event

478−decodeFile file i = do

483+decodeFile file =

479− fp <- liftIO $ mallocForeignPtrBytes parserSize

484+ C.sourceIO alloc cleanup (runParser . fst)

480− liftIO $ addForeignPtrFinalizer c_yaml_parser_delete fp

485+ where

486+ alloc = mask_ $ do

487+ ptr <- mallocBytes parserSize

481− res <- liftIO $ withForeignPtr fp c_yaml_parser_initialize

488+ res <- c_yaml_parser_initialize ptr

482− a <-

483− if res == 0

489+ if res == 0

490+ then do

491+ c_yaml_parser_delete ptr

492+ free ptr

484− then throwError $ YamlException "Yaml out of memory"

493+ throwIO $ YamlException "Yaml out of memory"

485− else do

494+ else do

486− file' <- liftIO

495+ file' <- liftIO

487− $ withCString file $ \file' -> withCString "r" $ \r' ->

496+ $ withCString file $ \file' -> withCString "r" $ \r' ->

488− c_fopen file' r'

497+ c_fopen file' r'

489− liftIO $ addForeignPtrFinalizerEnv c_fclose_helper file' fp

490− if (file' == nullPtr)

498+ if file' == nullPtr

499+ then do

500+ c_fclose_helper file'

501+ c_yaml_parser_delete ptr

502+ free ptr

491− then throwError $ YamlException

503+ throwIO $ YamlException

492− $ "Yaml file not found: " ++ file

504+ $ "Yaml file not found: " ++ file

493− else do

505+ else do

494− liftIO $ withForeignPtr fp $ \p ->

495− c_yaml_parser_set_input_file p file'

506+ c_yaml_parser_set_input_file ptr file'

496− a <- runParser fp i

507+ return (ptr, file')

497− return a

508+ cleanup (ptr, file') = do

498− return a

509+ c_fclose_helper file'

499−

510+ c_yaml_parser_delete ptr

500−runParser :: MonadIO m

511+ free ptr

501− => ForeignPtr ParserStruct

512+

502− -> Enumerator Event m a

513+runParser :: ResourceIO m => Parser -> m (C.SourceResult Event)

503−runParser fp (Continue k) = do

514+runParser parser = liftIO $ do

504− e <- liftIO $ withForeignPtr fp parserParseOne'

515+ e <- parserParseOne' parser

505 case e of

516 case e of

506− Left err -> throwError $ YamlException err

517+ Left err -> throwIO $ YamlException err

507− Right Nothing -> continue k

518+ Right Nothing -> return $ C.Closed

508− Right (Just ev) -> do

519+ Right (Just ev) -> return $ C.Open ev

509− step' <- lift $ runIteratee $ k $ Chunks [ev]

510− runParser fp step'

511−runParser _ step = returnI step

512

520

513parserParseOne' :: Parser

521parserParseOne' :: Parser

514 -> IO (Either String (Maybe Event))

522 -> IO (Either String (Maybe Event))

@@ -529,57 +537,60 @@ parserParseOne' parser = allocaBytes eventSize $ \er -> do

529 , show offset

537 , show offset

530 , "\n"

538 , "\n"

531 ]

539 ]

532− else liftIO $ Right <$> getEvent er

540+ else Right <$> getEvent er

533−

541+

534−encode :: MonadIO m => Iteratee Event m B.ByteString

542+encode :: ResourceIO m => C.Sink Event m ByteString

535−encode = do

543+encode =

536− fp <- liftIO $ mallocForeignPtrBytes emitterSize

537− res <- liftIO $ withForeignPtr fp c_yaml_emitter_initialize

538− when (res == 0) $ throwError

539− $ YamlException "c_yaml_emitter_initialize failed"

540− buf <- liftIO $ mallocForeignPtrBytes bufferSize

541− liftIO $ withForeignPtr buf c_buffer_init

542− liftIO $ withForeignPtr fp $

543− \emitter -> withForeignPtr buf $

544− \b -> c_my_emitter_set_output emitter b

545− runEmitter (go buf) fp

544+ runEmitter alloc close

546 where

545 where

547− go buf = withForeignPtr buf $ \b -> do

546+ alloc emitter = do

547+ fbuf <- mallocForeignPtrBytes bufferSize

548+ withForeignPtr fbuf c_buffer_init

549+ withForeignPtr fbuf $ c_my_emitter_set_output emitter

550+ return fbuf

551+ close fbuf = withForeignPtr fbuf $ \b -> do

548 ptr' <- c_get_buffer_buff b

552 ptr' <- c_get_buffer_buff b

549 len <- c_get_buffer_used b

553 len <- c_get_buffer_used b

550 fptr <- newForeignPtr_ $ castPtr ptr'

554 fptr <- newForeignPtr_ $ castPtr ptr'

551 return $ B.fromForeignPtr fptr 0 $ fromIntegral len

555 return $ B.fromForeignPtr fptr 0 $ fromIntegral len

552

556

553−encodeFile :: MonadIO m

557+encodeFile :: ResourceIO m

554 => FilePath

558 => FilePath

555− -> Iteratee Event m ()

559+ -> C.Sink Event m ()

556−encodeFile filePath = do

560+encodeFile filePath = C.Sink $ do

557− fp <- liftIO $ mallocForeignPtrBytes emitterSize

561+ (releaseKey, file) <- flip withIO c_fclose $ do

558− res <- liftIO $ withForeignPtr fp c_yaml_emitter_initialize

559− when (res == 0) $ throwError

560− $ YamlException "c_yaml_emitter_initialize failed"

561− file <- liftIO $ withCString filePath $

562+ file <- liftIO $ withCString filePath $

562− \filePath' -> withCString "w" $

563+ \filePath' -> withCString "w" $

563− \w' -> c_fopen filePath' w'

564+ \w' -> c_fopen filePath' w'

564− when (file == nullPtr) $ throwError

565+ if (file == nullPtr)

565− $ YamlException $ "could not open file for write: " ++ filePath

566+ then throwIO $ YamlException $ "could not open file for write: " ++ filePath

567+ else return file

568+ C.prepareSink $ runEmitter (alloc file) (return) -- FIXME close file early

569+ where

570+ alloc file emitter = do

566− liftIO $ withForeignPtr fp $ flip c_yaml_emitter_set_output_file file

571+ c_yaml_emitter_set_output_file emitter file

567− runEmitter (c_fclose file) fp

572+ return ()

568−

573+

569−runEmitter :: MonadIO m

574+runEmitter :: ResourceIO m

570− => IO a

575+ => (Emitter -> IO a) -- ^ alloc

571− -> ForeignPtr EmitterStruct

576+ -> (a -> IO b) -- ^ close

572− -> Iteratee Event m a

577+ -> C.Sink Event m b

573−runEmitter close fp = continue go

578+runEmitter allocI closeI =

579+ C.sinkIO alloc cleanup push close

574 where

580 where

575− go EOF = do

581+ alloc = mask_ $ do

582+ emitter <- mallocBytes emitterSize

583+ res <- c_yaml_emitter_initialize emitter

584+ when (res == 0) $ throwIO $ YamlException "c_yaml_emitter_initialize failed"

585+ a <- allocI emitter

586+ return (emitter, a)

587+ cleanup (emitter, _) = do

576− liftIO $ withForeignPtr fp c_yaml_emitter_delete

588+ c_yaml_emitter_delete emitter

577− a <- liftIO close

589+ free emitter

578− yield a EOF

590+ push (emitter, _) e = do

579− go (Chunks c) = do

580− liftIO $ withForeignPtr fp $ \emitter ->

581− mapM_ (\e -> toEventRaw e $ c_yaml_emitter_emit emitter) c

591+ liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter

582− continue go

592+ return C.Processing

593+ close (_, a) = liftIO $ closeI a

583

594

584data YamlException = YamlException String

595data YamlException = YamlException String

585 deriving (Show, Typeable)

596 deriving (Show, Typeable)

c/helper.c+1−1

@@ -135,7 +135,7 @@ int yaml_parser_set_input_filename(yaml_parser_t *parser, const char *filename)

135 yaml_parser_set_input_file(parser, in);

136}

137

138−int fclose_helper(FILE *file, yaml_parser_t *parser)

138+int fclose_helper(FILE *file)

139{

140 if (! file) return 0;

141 return fclose(file);

runtests.hs+19−34

@@ -1,5 +1,6 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE PackageImports #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

3import Test.Framework (defaultMain)

4import Test.Framework (defaultMain)

5import Text.Libyaml

6import Text.Libyaml

@@ -8,12 +9,13 @@ import qualified Data.ByteString.Char8 as B8

8import Test.Framework.Providers.HUnit

9import Test.Framework.Providers.HUnit

9import Test.HUnit hiding (Test, path)

10import Test.HUnit hiding (Test, path)

11−import qualified Data.Enumerator as E

12+import qualified Data.Conduit as C

12−import Data.Enumerator (($$))

13+import qualified Data.Conduit.List as CL

13import Data.List (foldl')

14import Data.List (foldl')

15import System.Directory

16import System.Directory

16import Control.Monad

17import Control.Monad

18+import Control.Exception (try, SomeException)

18main :: IO ()

20main :: IO ()

19main = defaultMain

21main = defaultMain

@@ -29,19 +31,16 @@ main = defaultMain

29 , testCase "decode invalid document (without segfault)" caseDecodeInvalidDocument

31 , testCase "decode invalid document (without segfault)" caseDecodeInvalidDocument

30 ]

32 ]

32−counter :: (Event -> Bool) -> Int -> E.Step Event IO Int

34+counter :: (Event -> Bool) -> Int -> C.Sink Event IO Int

33counter pred' acc =

35counter pred' acc =

34− E.Continue go

36+ CL.fold (\cnt e -> (if pred' e then 1 else 0) + cnt) 0

35− where

36− go E.EOF = E.yield acc E.EOF

37− go (E.Chunks c) = E.returnI $ counter pred' $ length (filter pred' c) + acc

39caseHelper :: String

38caseHelper :: String

40 -> (Event -> Bool)

39 -> (Event -> Bool)

41 -> Int

40 -> Int

42 -> Assertion

41 -> Assertion

43caseHelper yamlString pred' expRes = do

42caseHelper yamlString pred' expRes = do

44− Right res <- E.run $ decode (B8.pack yamlString) (counter pred' 0)

43+ res <- C.runResourceT $ decode (B8.pack yamlString) C.$$ counter pred' 0

45 res @?= expRes

44 res @?= expRes

47caseCountScalarsWithAnchor :: Assertion

46caseCountScalarsWithAnchor :: Assertion

@@ -78,15 +77,11 @@ caseCountAliases =

79caseCountScalars :: Assertion

78caseCountScalars :: Assertion

80caseCountScalars = do

79caseCountScalars = do

81− Right res <- E.run $ decode yamlBS $ counter' accum

80+ res <- C.runResourceT $ decode yamlBS C.$$ CL.fold adder accum

82 res @?= (7, 1, 2)

81 res @?= (7, 1, 2)

83 where

82 where

84 yamlString = "foo:\n baz: [bin1, bin2, bin3]\nbaz: bazval"

83 yamlString = "foo:\n baz: [bin1, bin2, bin3]\nbaz: bazval"

85 yamlBS = B8.pack yamlString

84 yamlBS = B8.pack yamlString

86− counter' acc = E.Continue $ \s ->

87− case s of

88− E.EOF -> E.yield acc E.EOF

89− E.Chunks c -> E.returnI $ counter' $ foldl' adder acc c

90 adder (s, l, m) (EventScalar{}) = (s + 1, l, m)

85 adder (s, l, m) (EventScalar{}) = (s + 1, l, m)

91 adder (s, l, m) (EventSequenceStart{}) = (s, l + 1, m)

86 adder (s, l, m) (EventSequenceStart{}) = (s, l + 1, m)

92 adder (s, l, m) (EventMappingStart{}) = (s, l, m + 1)

87 adder (s, l, m) (EventMappingStart{}) = (s, l, m + 1)

@@ -95,17 +90,11 @@ caseCountScalars = do

96caseLargestString :: Assertion

91caseLargestString :: Assertion

97caseLargestString = do

92caseLargestString = do

98− Right res <- E.run $ decodeFile filePath $ dec accum

93+ res <- C.runResourceT $ decodeFile filePath C.$$ CL.fold adder accum

99 res @?= (length expected, expected)

94 res @?= (length expected, expected)

100 where

95 where

101 expected = "this one is just a little bit bigger than the others"

96 expected = "this one is just a little bit bigger than the others"

102 filePath = "test/largest-string.yaml"

97 filePath = "test/largest-string.yaml"

103− dec acc = E.Continue $ \s ->

104− case s of

105− E.EOF -> E.yield acc E.EOF

106− E.Chunks c ->

107− let acc' = foldl' adder acc c

108− in E.returnI $ dec acc'

109 adder (i, s) (EventScalar bs _ _ _) =

98 adder (i, s) (EventScalar bs _ _ _) =

110 let s' = B8.unpack bs

99 let s' = B8.unpack bs

111 i' = length s'

100 i' = length s'

@@ -121,9 +110,9 @@ instance Eq MyEvent where

121

110

122caseEncodeDecode :: Assertion

111caseEncodeDecode :: Assertion

123caseEncodeDecode = do

112caseEncodeDecode = do

124− Right eList <- E.run $ decode yamlBS $$ E.consume

113+ eList <- C.runResourceT $ decode yamlBS C.$$ CL.consume

125− Right bs <- E.run $ E.enumList 1 eList $$ encode

114+ bs <- C.runResourceT $ CL.sourceList eList C.$$ encode

126− Right eList2 <- E.run $ decode bs $$ E.consume

115+ eList2 <- C.runResourceT $ decode bs C.$$ CL.consume

127 map MyEvent eList @=? map MyEvent eList2

116 map MyEvent eList @=? map MyEvent eList2

128 where

117 where

129 yamlString = "foo: bar\nbaz:\n - bin1\n - bin2\n"

118 yamlString = "foo: bar\nbaz:\n - bin1\n - bin2\n"

@@ -137,9 +126,9 @@ removeFile' fp = do

137caseEncodeDecodeFile :: Assertion

126caseEncodeDecodeFile :: Assertion

138caseEncodeDecodeFile = do

127caseEncodeDecodeFile = do

139 removeFile' tmpPath

128 removeFile' tmpPath

140− Right eList <- E.run $ decodeFile filePath $$ E.consume

129+ eList <- C.runResourceT $ decodeFile filePath C.$$ CL.consume

141− E.run $ E.enumList 1 eList $$ encodeFile tmpPath

130+ C.runResourceT $ CL.sourceList eList C.$$ encodeFile tmpPath

142− Right eList2 <- E.run $ decodeFile filePath $$ E.consume

131+ eList2 <- C.runResourceT $ decodeFile filePath C.$$ CL.consume

143 map MyEvent eList @=? map MyEvent eList2

132 map MyEvent eList @=? map MyEvent eList2

144 where

133 where

145 filePath = "test/largest-string.yaml"

134 filePath = "test/largest-string.yaml"

@@ -149,8 +138,8 @@ caseInterleave :: Assertion

149caseInterleave = do

138caseInterleave = do

150 removeFile' tmpPath

139 removeFile' tmpPath

151 removeFile' tmpPath2

140 removeFile' tmpPath2

152− Right () <- E.run $ decodeFile filePath $$ encodeFile tmpPath

141+ () <- C.runResourceT $ decodeFile filePath C.$$ encodeFile tmpPath

153− Right () <- E.run $ decodeFile tmpPath $$ encodeFile tmpPath2

142+ () <- C.runResourceT $ decodeFile tmpPath C.$$ encodeFile tmpPath2

154 f1 <- readFile tmpPath

143 f1 <- readFile tmpPath

155 f2 <- readFile tmpPath2

144 f2 <- readFile tmpPath2

156 f1 @=? f2

145 f1 @=? f2

@@ -161,16 +150,12 @@ caseInterleave = do

161

150

162caseDecodeInvalidDocument :: Assertion

151caseDecodeInvalidDocument :: Assertion

163caseDecodeInvalidDocument = do

152caseDecodeInvalidDocument = do

164− x <- E.run $ decode yamlBS ignore

153+ x <- try $ C.runResourceT $ decode yamlBS C.$$ CL.sinkNull

165 case x of

154 case x of

166− Left _ -> return ()

155+ Left (e :: SomeException) -> return ()

167 Right y -> do

156 Right y -> do

168 putStrLn $ "bad return value: " ++ show y

157 putStrLn $ "bad return value: " ++ show y

169 assertFailure "expected parsing exception, but got no errors"

158 assertFailure "expected parsing exception, but got no errors"

170 where

159 where

171 yamlString = " - foo\n - baz\nbuz"

160 yamlString = " - foo\n - baz\nbuz"

172 yamlBS = B8.pack yamlString

161 yamlBS = B8.pack yamlString

173− ignore = E.Continue $ \s ->

174− case s of

175− E.EOF -> E.yield () E.EOF

176− E.Chunks _-> E.returnI ignore

yaml.cabal+16−29

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

1name: yaml

2−version: 0.4.1.2

2+version: 0.5.0

3license: BSD3

4license-file: LICENSE

5author: Michael Snoyman <michael@snoyman.com>, Anton Ageev <antage@gmail.com>,Kirill Simonov

@@ -39,7 +39,7 @@ library

39 build-depends: base >= 4 && < 5

40 , transformers >= 0.1 && < 0.3

41 , bytestring >= 0.9.1.4 && < 0.10

42− , enumerator >= 0.4 && < 0.5

42+ , conduit >= 0.0 && < 0.1

43 exposed-modules: Text.Libyaml

44 ghc-options: -Wall

45 c-sources: c/helper.c

@@ -57,33 +57,20 @@ library

57 libyaml/writer.c

58 include-dirs: libyaml

60−executable runtests

60+test-suite runtests

61− if flag(buildtests)

61+ type: exitcode-stdio-1.0

62− Buildable: True

62+ main-is: runtests.hs

63− cpp-options: -DTEST

63+ cpp-options: -DTEST

64− build-depends: test-framework

64+ build-depends: test-framework

65− , test-framework-hunit

65+ , test-framework-hunit

66− , HUnit

66+ , HUnit

67− , directory

67+ , directory

68− , base >= 4 && < 5

68+ , base >= 4 && < 5

69− , transformers >= 0.1 && < 0.3

69+ , transformers >= 0.1 && < 0.3

70− , bytestring >= 0.9.1.4 && < 0.10

70+ , bytestring >= 0.9.1.4 && < 0.10

71− , enumerator >= 0.4 && < 0.5

71+ , conduit

72− else

73− Buildable: False

74 ghc-options: -Wall

72 ghc-options: -Wall

75 c-sources: c/helper.c

73 c-sources: c/helper.c

76 include-dirs: c

74 include-dirs: c

77− if flag(system-libyaml)

78− pkgconfig-depends: yaml-0.1

75+ pkgconfig-depends: yaml-0.1

79− else

76+ extra-libraries: yaml

80− c-sources: libyaml/api.c,

81− libyaml/dumper.c,

82− libyaml/emitter.c,

83− libyaml/loader.c,

84− libyaml/parser.c,

85− libyaml/reader.c,

86− libyaml/scanner.c,

87− libyaml/writer.c

88− include-dirs: libyaml

89− main-is: runtests.hs