b1694ae · typeable/yaml

git.iko.soy/typeable/yaml

Migrate to conduit

commitb1694ae8c09acd87d56ec6530915992cc1afdbc2 authorMichael Snoyman <michael@snoyman.com> dateWed 28 Dec 2011, 11:53 (15 years ago) parent9ec21cb

4 files changed+148−165

compare with master

unifiedsplit

Text/Libyaml.hs+112−101 c/helper.c+1−1 runtests.hs+19−34 yaml.cabal+16−29

Text/Libyaml.hs+112−101

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

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

4242

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

44−import Data.Enumerator

4544import Control.Applicative

45+import Control.Monad.Trans.Resource

46+import qualified Data.Conduit as C

4647

4748data Event =

4849 EventStreamStart

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

120121foreign import ccall unsafe "yaml_parser_initialize"

121122 c_yaml_parser_initialize :: Parser -> IO CInt

122123

123−foreign import ccall unsafe "&yaml_parser_delete"

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

124+foreign import ccall unsafe "yaml_parser_delete"

125+ c_yaml_parser_delete :: Parser -> IO ()

125126

126127foreign import ccall unsafe "yaml_parser_set_input_string"

127128 c_yaml_parser_set_input_string :: Parser

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

146147 c_fclose :: File

147148 -> IO ()

148149

149−foreign import ccall unsafe "&fclose_helper"

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

150+foreign import ccall unsafe "fclose_helper"

151+ c_fclose_helper :: File -> IO ()

151152

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

153154withForeignPtr' fp f = do

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

455456 deriving (Show, Typeable)

456457instance Exception ToEventRawException

457458

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

459−decode bs i = do

460− fp <- liftIO $ mallocForeignPtrBytes parserSize

461− res <- liftIO $ withForeignPtr fp c_yaml_parser_initialize

462− liftIO $ addForeignPtrFinalizer c_yaml_parser_delete fp

463− a <-

464− if (res == 0)

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

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

467− -- since it must run in a MonadIO

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

469− withForeignPtr' fptr $ \ptr -> do

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

471− len' = fromIntegral len

472− liftIO $ withForeignPtr fp $ \p ->

473− c_yaml_parser_set_input_string p ptr' len'

474− runParser fp i

475− return a

476−

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

478−decodeFile file i = do

479− fp <- liftIO $ mallocForeignPtrBytes parserSize

480− liftIO $ addForeignPtrFinalizer c_yaml_parser_delete fp

481− res <- liftIO $ withForeignPtr fp c_yaml_parser_initialize

482− a <-

483− if res == 0

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

485− else do

486− file' <- liftIO

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

488− c_fopen file' r'

489− liftIO $ addForeignPtrFinalizerEnv c_fclose_helper file' fp

490− if (file' == nullPtr)

491− then throwError $ YamlException

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

493− else do

494− liftIO $ withForeignPtr fp $ \p ->

495− c_yaml_parser_set_input_file p file'

496− a <- runParser fp i

497− return a

498− return a

499−

500−runParser :: MonadIO m

501− => ForeignPtr ParserStruct

502− -> Enumerator Event m a

503−runParser fp (Continue k) = do

504− e <- liftIO $ withForeignPtr fp parserParseOne'

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

460+decode bs =

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

462+ where

463+ alloc = mask_ $ do

464+ ptr <- mallocBytes parserSize

465+ res <- c_yaml_parser_initialize ptr

466+ if res == 0

467+ then do

468+ c_yaml_parser_delete ptr

469+ free ptr

470+ throwIO $ YamlException "Yaml out of memory"

471+ else do

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

473+ let bsptrOrig = unsafeForeignPtrToPtr bsfptr

474+ let bsptr = castPtr bsptrOrig `plusPtr` offset

475+ c_yaml_parser_set_input_string ptr bsptr (fromIntegral len)

476+ return (ptr, bsfptr)

477+ cleanup (ptr, bsfptr) = do

478+ touchForeignPtr bsfptr

479+ c_yaml_parser_delete ptr

480+ free ptr

481+

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

483+decodeFile file =

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

485+ where

486+ alloc = mask_ $ do

487+ ptr <- mallocBytes parserSize

488+ res <- c_yaml_parser_initialize ptr

489+ if res == 0

490+ then do

491+ c_yaml_parser_delete ptr

492+ free ptr

493+ throwIO $ YamlException "Yaml out of memory"

494+ else do

495+ file' <- liftIO

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

497+ c_fopen file' r'

498+ if file' == nullPtr

499+ then do

500+ c_fclose_helper file'

501+ c_yaml_parser_delete ptr

502+ free ptr

503+ throwIO $ YamlException

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

505+ else do

506+ c_yaml_parser_set_input_file ptr file'

507+ return (ptr, file')

508+ cleanup (ptr, file') = do

509+ c_fclose_helper file'

510+ c_yaml_parser_delete ptr

511+ free ptr

512+

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

514+runParser parser = liftIO $ do

515+ e <- parserParseOne' parser

505516 case e of

506− Left err -> throwError $ YamlException err

507− Right Nothing -> continue k

508− Right (Just ev) -> do

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

510− runParser fp step'

511−runParser _ step = returnI step

517+ Left err -> throwIO $ YamlException err

518+ Right Nothing -> return $ C.Closed

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

512520

513521parserParseOne' :: Parser

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

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

529537 , show offset

530538 , "\n"

531539 ]

532− else liftIO $ Right <$> getEvent er

533−

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

535−encode = do

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

540+ else Right <$> getEvent er

541+

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

543+encode =

544+ runEmitter alloc close

546545 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

548552 ptr' <- c_get_buffer_buff b

549553 len <- c_get_buffer_used b

550554 fptr <- newForeignPtr_ $ castPtr ptr'

551555 return $ B.fromForeignPtr fptr 0 $ fromIntegral len

552556

553−encodeFile :: MonadIO m

557+encodeFile :: ResourceIO m

554558 => FilePath

555− -> Iteratee Event m ()

556−encodeFile filePath = do

557− fp <- liftIO $ mallocForeignPtrBytes emitterSize

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− \filePath' -> withCString "w" $

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

564− when (file == nullPtr) $ throwError

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

566− liftIO $ withForeignPtr fp $ flip c_yaml_emitter_set_output_file file

567− runEmitter (c_fclose file) fp

568−

569−runEmitter :: MonadIO m

570− => IO a

571− -> ForeignPtr EmitterStruct

572− -> Iteratee Event m a

573−runEmitter close fp = continue go

559+ -> C.Sink Event m ()

560+encodeFile filePath = C.Sink $ do

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

562+ file <- liftIO $ withCString filePath $

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

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

565+ if (file == nullPtr)

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

571+ c_yaml_emitter_set_output_file emitter file

572+ return ()

573+

574+runEmitter :: ResourceIO m

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

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

577+ -> C.Sink Event m b

578+runEmitter allocI closeI =

579+ C.sinkIO alloc cleanup push close

574580 where

575− go EOF = do

576− liftIO $ withForeignPtr fp c_yaml_emitter_delete

577− a <- liftIO close

578− yield a EOF

579− go (Chunks c) = do

580− liftIO $ withForeignPtr fp $ \emitter ->

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

582− continue go

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

588+ c_yaml_emitter_delete emitter

589+ free emitter

590+ push (emitter, _) e = do

591+ liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter

592+ return C.Processing

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

583594

584595data YamlException = YamlException String

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

135135 yaml_parser_set_input_file(parser, in);

136136}

137137

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

138+int fclose_helper(FILE *file)

139139{

140140 if (! file) return 0;

141141 return fclose(file);

runtests.hs+19−34

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

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE PackageImports #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

34import Test.Framework (defaultMain)

56import Text.Libyaml

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

89import Test.Framework.Providers.HUnit

910import Test.HUnit hiding (Test, path)

1011

11−import qualified Data.Enumerator as E

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

12+import qualified Data.Conduit as C

13+import qualified Data.Conduit.List as CL

1314import Data.List (foldl')

1415

1516import System.Directory

1617import Control.Monad

18+import Control.Exception (try, SomeException)

1719

1820main :: IO ()

1921main = defaultMain

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

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

3032 ]

3133

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

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

3335counter pred' acc =

34− E.Continue go

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

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

3837

3938caseHelper :: String

4039 -> (Event -> Bool)

4140 -> Int

4241 -> Assertion

4342caseHelper 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

4544 res @?= expRes

4645

4746caseCountScalarsWithAnchor :: Assertion

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

7877

7978caseCountScalars :: Assertion

8079caseCountScalars = do

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

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

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

8382 where

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

8584 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

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

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

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

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

9590

9691caseLargestString :: Assertion

9792caseLargestString = do

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

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

9994 res @?= (length expected, expected)

10095 where

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

10297 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'

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

11099 let s' = B8.unpack bs

111100 i' = length s'

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

121110

122111caseEncodeDecode :: Assertion

123112caseEncodeDecode = do

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

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

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

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

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

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

127116 map MyEvent eList @=? map MyEvent eList2

128117 where

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

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

137126caseEncodeDecodeFile :: Assertion

138127caseEncodeDecodeFile = do

139128 removeFile' tmpPath

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

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

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

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

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

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

143132 map MyEvent eList @=? map MyEvent eList2

144133 where

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

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

149138caseInterleave = do

150139 removeFile' tmpPath

151140 removeFile' tmpPath2

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

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

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

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

154143 f1 <- readFile tmpPath

155144 f2 <- readFile tmpPath2

156145 f1 @=? f2

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

161150

162151caseDecodeInvalidDocument :: Assertion

163152caseDecodeInvalidDocument = do

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

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

165154 case x of

166− Left _ -> return ()

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

167156 Right y -> do

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

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

170159 where

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

172161 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 @@

11name: yaml

2−version: 0.4.1.2

2+version: 0.5.0

33license: BSD3

44license-file: LICENSE

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

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

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

4040 , transformers >= 0.1 && < 0.3

4141 , bytestring >= 0.9.1.4 && < 0.10

42− , enumerator >= 0.4 && < 0.5

42+ , conduit >= 0.0 && < 0.1

4343 exposed-modules: Text.Libyaml

4444 ghc-options: -Wall

4545 c-sources: c/helper.c

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

5757 libyaml/writer.c

5858 include-dirs: libyaml

5959

60−executable runtests

61− if flag(buildtests)

62− Buildable: True

63− cpp-options: -DTEST

64− build-depends: test-framework

65− , test-framework-hunit

66− , HUnit

67− , directory

68− , base >= 4 && < 5

69− , transformers >= 0.1 && < 0.3

70− , bytestring >= 0.9.1.4 && < 0.10

71− , enumerator >= 0.4 && < 0.5

72− else

73− Buildable: False

60+test-suite runtests

61+ type: exitcode-stdio-1.0

62+ main-is: runtests.hs

63+ cpp-options: -DTEST

64+ build-depends: test-framework

65+ , test-framework-hunit

66+ , HUnit

67+ , directory

68+ , base >= 4 && < 5

69+ , transformers >= 0.1 && < 0.3

70+ , bytestring >= 0.9.1.4 && < 0.10

71+ , conduit

7472 ghc-options: -Wall

7573 c-sources: c/helper.c

7674 include-dirs: c

77− if flag(system-libyaml)

78− pkgconfig-depends: yaml-0.1

79− else

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

75+ pkgconfig-depends: yaml-0.1

76+ extra-libraries: yaml