@@ -16,25 +16,7 @@ module Text.Libyaml
1616 , Tag (..)
1717 , AnchorName
1818 , Anchor
19− -- * Exceptions
20− , YamlException (..)
21− -- * Enumerator
22− , With (..)
23− -- * Encoder
24− , YamlEncoder
25− , YamlDecoder
26− , Parser
27− , parseEvent
28− , parserParseOne
29− , emitEvent
30− -- ** Combinators
31− , emitStream
32− , emitDocument
33− , emitSequence
34− , emitSequenceWithAnchor
35− , emitMapping
36− , emitMappingWithAnchor
37− -- * Higher level functions
19+ -- * Encoding and decoding
3820 , encode
3921 , decode
4022 , encodeFile
@@ -50,16 +32,14 @@ import Foreign.C
5032import Foreign.Ptr
5133import Foreign.ForeignPtr
5234import Foreign.Marshal.Alloc
35+
5336#if MIN_VERSION_transformers(0,2,0)
5437import "transformers" Control.Monad.IO.Class
5538#else
5639import "transformers" Control.Monad.Trans
5740#endif
58−import Control.Monad.Failure.Transformers
59−import qualified Control.Monad.Trans.Error as ErrorT
60−import Control.Monad.Trans.Reader
6141
62−import Control.Exception (throwIO, Exception, SomeException)
42+import Control.Exception (throwIO, Exception)
6343import Data.Typeable (Typeable)
6444import Data.Iteratee
6545import qualified Data.Iteratee.Base.StreamChunk as SC
@@ -131,30 +111,6 @@ stringToTag "tag:yaml.org,2002:map" = MapTag
131111stringToTag "" = NoTag
132112stringToTag s = UriTag s
133113
134−data YamlException =
135− YamlParserException
136− { parserProblem :: String
137− , parserContext :: String
138− , parserOffset :: Int
139− }
140− | YamlEmitterException
141− { emitterEvent :: Event
142− , emitterProblem :: String
143− }
144− | YamlOutOfMemory
145− | YamlInvalidEventStreamBeginning [Event]
146− | YamlInvalidEventStreamEnd [Event]
147− | YamlPrematureEventStreamEnd
148− | YamlNonScalarKey
149− | YamlInvalidStartingEvent Event
150− | YamlFileNotFound FilePath
151− | YamlOtherException SomeException
152− | YamlStringException String
153− deriving (Show, Typeable)
154−instance Exception YamlException
155−instance ErrorT.Error YamlException where
156− strMsg = YamlStringException
157−
158114data ParserStruct
159115type Parser = Ptr ParserStruct
160116parserSize :: Int
@@ -194,24 +150,6 @@ foreign import ccall unsafe "fclose"
194150 c_fclose :: File
195151 -> IO ()
196152
197−class MonadIO m => With m where
198− with :: (forall b'. (a -> IO b') -> IO b') -> (a -> m b) -> m b
199−
200−instance With IO where
201− with = id
202−instance With m => With (ReaderT r m) where
203− with orig f = ReaderT $ \r -> do
204− let f' a = (runReaderT $ f a) r
205− with orig f'
206−instance (ErrorT.Error e, With m) => With (ErrorT.ErrorT e m) where
207− with orig f = ErrorT.ErrorT $ with orig $ ErrorT.runErrorT . f
208−
209−allocaBytesR :: With m => Int -> (Ptr a -> m b) -> m b
210−allocaBytesR i = with (allocaBytes i)
211−
212−withCStringR :: With m => String -> (Ptr CChar -> m a) -> m a
213−withCStringR s = with (withCString s)
214−
215153withForeignPtr' :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b
216154withForeignPtr' fp f = do
217155 r <- f $ unsafeForeignPtrToPtr fp
@@ -240,23 +178,6 @@ makeString f a = do
240178 then return ""
241179 else liftIO $ peekCString cchar
242180
243−parserParseOne :: (MonadFailure YamlException m, With m)
244− => Parser
245− -> m (Maybe Event)
246−parserParseOne parser = allocaBytesR eventSize $ \er -> do
247− res <- liftIO $ c_yaml_parser_parse parser er
248− event <-
249− if res == 0
250− then do
251− problem <- liftIO $ makeString c_get_parser_error_problem parser
252− context <- liftIO $ makeString c_get_parser_error_context parser
253− offset <- liftIO $ fromIntegral `fmap`
254− c_get_parser_error_offset parser
255− failure $ YamlParserException problem context offset
256− else liftIO $ getEvent er
257− liftIO $ c_yaml_event_delete er -- FIXME use finally
258− return event
259−
260181data EventType = YamlNoEvent
261182 | YamlStreamStartEvent
262183 | YamlStreamEndEvent
@@ -389,47 +310,6 @@ foreign import ccall unsafe "yaml_emitter_set_output_file"
389310foreign import ccall unsafe "yaml_emitter_emit"
390311 c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
391312
392−foreign import ccall unsafe "get_emitter_error"
393− c_get_emitter_error :: Emitter -> IO (Ptr CUChar)
394−
395−emitEvent :: (MonadIO m, MonadFailure YamlException m)
396− => Event
397− -> YamlEncoder m ()
398−emitEvent e = do
399− emitter <- ask
400− res <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter
401− when (res == 0) $ do
402− problem <- liftIO $ makeString c_get_emitter_error emitter
403− failure $ YamlEmitterException e problem
404−
405−emitStream, emitDocument, emitSequence, emitMapping
406− :: (MonadIO m, MonadFailure YamlException m)
407− => YamlEncoder m ()
408− -> YamlEncoder m ()
409−emitStream e = emitEvent EventStreamStart >> e >> emitEvent EventStreamEnd
410−emitDocument e = emitEvent EventDocumentStart >> e
411− >> emitEvent EventDocumentEnd
412−emitSequence e = emitSequenceWithAnchor e Nothing
413−emitMapping e = emitMappingWithAnchor e Nothing
414−
415−emitSequenceWithAnchor, emitMappingWithAnchor
416− :: (MonadIO m, MonadFailure YamlException m)
417− => YamlEncoder m ()
418− -> Anchor
419− -> YamlEncoder m ()
420−emitSequenceWithAnchor e a = emitEvent (EventSequenceStart a) >> e
421− >> emitEvent EventSequenceEnd
422−emitMappingWithAnchor e a = emitEvent (EventMappingStart a) >> e
423− >> emitEvent EventMappingEnd
424−
425−
426−parseEvent :: (With m, MonadFailure YamlException m)
427− => YamlDecoder m (Maybe Event)
428−parseEvent = ask >>= parserParseOne
429−
430−type YamlDecoder = ReaderT Parser
431−type YamlEncoder = ReaderT Emitter
432−
433313foreign import ccall unsafe "yaml_stream_start_event_initialize"
434314 c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt
435315
@@ -485,7 +365,7 @@ foreign import ccall unsafe "yaml_alias_event_initialize"
485365 -> IO CInt
486366
487367toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
488−toEventRaw e f = allocaBytesR eventSize $ \er -> do
368+toEventRaw e f = allocaBytes eventSize $ \er -> do
489369 ret <- case e of
490370 EventStreamStart ->
491371 c_yaml_stream_start_event_initialize
@@ -613,7 +493,7 @@ decodeFile file i = do
613493 then return $ throwErr $ Err "Yaml out of memory"
614494 else do
615495 file' <- liftIO
616− $ withCStringR file $ \file' -> withCStringR "r" $ \r' ->
496+ $ withCString file $ \file' -> withCString "r" $ \r' ->
617497 c_fopen file' r'
618498 if (file' == nullPtr)
619499 then return $ throwErr $ Err
@@ -643,17 +523,24 @@ runParser fp iter = do
643523 Cont _ (Just err) -> return $ throwErr err
644524
645525parserParseOne' :: Parser
646− -> IO (Either YamlException (Maybe Event))
647−parserParseOne' parser = allocaBytesR eventSize $ \er -> do
526+ -> IO (Either String (Maybe Event))
527+parserParseOne' parser = allocaBytes eventSize $ \er -> do
648528 res <- liftIO $ c_yaml_parser_parse parser er
649529 flip finally (c_yaml_event_delete er) $
650530 if res == 0
651531 then do
652532 problem <- makeString c_get_parser_error_problem parser
653533 context <- makeString c_get_parser_error_context parser
654− offset <- fromIntegral `fmap`
655− c_get_parser_error_offset parser
656− return $ Left $ YamlParserException problem context offset
534+ offset <- c_get_parser_error_offset parser
535+ return $ Left $ concat
536+ [ "YAML parse error: "
537+ , problem
538+ , "\nContext: "
539+ , context
540+ , "\nOffset: "
541+ , show offset
542+ , "\n"
543+ ]
657544 else liftIO $ Right <$> getEvent er
658545
659546encode :: SC.StreamChunk c Event
@@ -685,8 +572,8 @@ encodeFile filePath = joinIM $ liftIO $ do
685572 fp <- mallocForeignPtrBytes emitterSize
686573 res <- withForeignPtr fp c_yaml_emitter_initialize
687574 when (res == 0) $ fail "c_yaml_emitter_initialize failed"
688− file <- withCStringR filePath $
689− \filePath' -> withCStringR "w" $
575+ file <- withCString filePath $
576+ \filePath' -> withCString "w" $
690577 \w' -> c_fopen filePath' w'
691578 when (file == nullPtr) $ fail $ "could not open file for write: " ++ filePath
692579 withForeignPtr fp $ flip c_yaml_emitter_set_output_file file