git.iko.soy/typeable/yaml
on master help sign in
Switch to Attempt
1e63f84Michael Snoyman
Text/Libyaml.hs+2
compare with master
unifiedsplit
@@ -70,6 +70,7 @@ foreign import ccall unsafe "yaml_event_delete"
70foreign import ccall "print_parser_error"
70foreign import ccall "print_parser_error"
71 c_print_parser_error :: Parser -> IO ()
71 c_print_parser_error :: Parser -> IO ()
72
72
73+-- FIXME more grace error handling
73parserParseOne :: Parser -> IO Event
74parserParseOne :: Parser -> IO Event
74parserParseOne parser = withEventRaw $ \er -> do
75parserParseOne parser = withEventRaw $ \er -> do
75 res <- c_yaml_parser_parse parser er
76 res <- c_yaml_parser_parse parser er
@@ -204,6 +205,7 @@ foreign import ccall unsafe "yaml_emitter_emit"
204foreign import ccall unsafe "print_emitter_error"
205foreign import ccall unsafe "print_emitter_error"
205 c_print_emitter_error :: Emitter -> IO ()
206 c_print_emitter_error :: Emitter -> IO ()
206
207
208+-- FIXME more graceful error handling
207emitEvents :: Emitter -> [Event] -> IO ()
209emitEvents :: Emitter -> [Event] -> IO ()
208emitEvents _ [] = return ()
210emitEvents _ [] = return ()
209emitEvents emitter (e:rest) = do
211emitEvents emitter (e:rest) = do
Text/Yaml.hs+27−16
@@ -33,6 +33,10 @@ import Data.Object.Raw
33import System.IO.Unsafe
33import System.IO.Unsafe
34import Control.Arrow (first, (***))
34import Control.Arrow (first, (***))
35import Control.Monad (replicateM)
35import Control.Monad (replicateM)
36+import Data.Attempt
37+import Control.Monad.Trans
38+import Control.Monad.Attempt
39+import Control.Monad.Attempt.Class
36
40
37import Test.Framework (testGroup, Test)
41import Test.Framework (testGroup, Test)
38import Test.Framework.Providers.HUnit
42import Test.Framework.Providers.HUnit
@@ -43,18 +47,22 @@ import Test.QuickCheck
43encode :: (StrictByteString bs, ToObject o Raw Raw) => o -> bs
47encode :: (StrictByteString bs, ToObject o Raw Raw) => o -> bs
44encode = unsafePerformIO . encode'
48encode = unsafePerformIO . encode'
45
49
46−decode :: (MonadFail m, StrictByteString bs, FromObject o Raw Raw)
50+decode :: (StrictByteString bs, FromObject o Raw Raw, MonadAttempt m)
47 => bs
51 => bs
48 -> m o
52 -> m o
49−decode = unsafePerformIO . decode'
53+decode bs = unsafePerformIO $ do
54+ a <- runAttemptT $ decode' bs -- FIXME
55+ case a of
56+ Success s -> return $ success s
57+ Failure e -> return $ failure e
50
58
51encodeFile :: ToObject o Raw Raw => FilePath -> o -> IO ()
59encodeFile :: ToObject o Raw Raw => FilePath -> o -> IO ()
52encodeFile path o = encode' o >>= B.writeFile path
60encodeFile path o = encode' o >>= B.writeFile path
53
61
54−decodeFile :: (MonadFail m, FromObject o Raw Raw) => FilePath -> IO (m o)
62+decodeFile :: (FromObject o Raw Raw, MonadAttempt m, MonadIO m)
63+ => FilePath
64+ -> m o
55−decodeFile path = do
65+decodeFile path = liftIO (B.readFile path) >>= decode'
56− c <- B.readFile path
57− decode' c
58
66
59encode' :: (StrictByteString bs, ToObject o Raw Raw) => o -> IO bs
67encode' :: (StrictByteString bs, ToObject o Raw Raw) => o -> IO bs
60encode' o =
68encode' o =
@@ -62,13 +70,15 @@ encode' o =
62 result = withEmitter $ flip emitEvents $ events
70 result = withEmitter $ flip emitEvents $ events
63 in fromStrictByteString `fmap` result
71 in fromStrictByteString `fmap` result
64
72
65−decode' :: (MonadFail m, StrictByteString bs, FromObject o Raw Raw)
73+decode' :: (StrictByteString bs, FromObject o Raw Raw, MonadIO m,
74+ MonadAttempt m)
66 => bs
75 => bs
67− -> IO (m o)
76+ -> m o
68decode' bs = do
77decode' bs = do
69− let bs' = toStrictByteString bs
78+ events <- liftIO $ withParser (toStrictByteString bs) parserParse
70− events = withParser bs' parserParse
71− (fromObject . eventsToRawObject) `fmap` events
79+ case fromObject $ eventsToRawObject events of -- FIXME something better in attempt
80+ Failure e -> failure e
81+ Success s -> success s
72
82
73objectToEvents :: RawObject -> [Event]
83objectToEvents :: RawObject -> [Event]
74objectToEvents y = concat
84objectToEvents y = concat
@@ -126,7 +136,8 @@ instance FromScalar MyString Raw where
126 fromScalar raw = MyString `fmap` fromScalar raw
136 fromScalar raw = MyString `fmap` fromScalar raw
127
137
128propEncodeDecode :: Object MyString MyString -> Bool
138propEncodeDecode :: Object MyString MyString -> Bool
129−propEncodeDecode o = decode (encode o :: B.ByteString) == Just o
139+propEncodeDecode o = fromAttempt (decode (encode o :: B.ByteString))
140+ == Just o
130
141
131caseEmptyStrings :: Assertion
142caseEmptyStrings :: Assertion
132caseEmptyStrings = do
143caseEmptyStrings = do
@@ -135,12 +146,12 @@ caseEmptyStrings = do
135 , ("baz", "")
146 , ("baz", "")
136 , ("bin", "")
147 , ("bin", "")
137 ]
148 ]
138− ma = m
139 let m' = map (toStrictByteString *** toStrictByteString) m
149 let m' = map (toStrictByteString *** toStrictByteString) m
140 let m'' = map (toLazyByteString *** toLazyByteString) m
150 let m'' = map (toLazyByteString *** toLazyByteString) m
141− Just ma @=? decode (encode ma :: String)
151+ let test' x = Just x @=? fromAttempt (decode (encode x :: String))
142− Just m' @=? decode (encode m' :: String)
152+ test' m
143− Just m'' @=? decode (encode m'' :: String)
153+ test' m'
154+ test' m''
144
155
145testSuite :: Test
156testSuite :: Test
146testSuite = testGroup "Text.Yaml"
157testSuite = testGroup "Text.Yaml"
yaml.cabal+3−2
@@ -25,9 +25,10 @@ library
25 test-framework-quickcheck,
25 test-framework-quickcheck,
26 test-framework-hunit,
26 test-framework-hunit,
27 HUnit,
27 HUnit,
28− safe,
29 time,
28 time,
30− QuickCheck >= 1 && < 2
29+ QuickCheck >= 1 && < 2,
30+ attempt,
31+ transformers >= 0.1.4.0
31 exposed-modules: Text.Yaml
32 exposed-modules: Text.Yaml
32 other-modules: Text.Libyaml
33 other-modules: Text.Libyaml
33 ghc-options: -Wall
34 ghc-options: -Wall