git.iko.soy/typeable/yaml
on master help sign in
Test flag and removed attempt dependency.
b9ae04fMichael Snoyman
Text/Libyaml.hs+49−17
compare with master
unifiedsplit
@@ -1,5 +1,8 @@
1{-# LANGUAGE EmptyDataDecls #-}
1{-# LANGUAGE EmptyDataDecls #-}
2{-# LANGUAGE ForeignFunctionInterface #-}
2{-# LANGUAGE ForeignFunctionInterface #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
3
6
4{-# INCLUDE <yaml.h> #-}
7{-# INCLUDE <yaml.h> #-}
5{-# INCLUDE <helper.h> #-}
8{-# INCLUDE <helper.h> #-}
@@ -20,7 +23,9 @@ import Foreign.Ptr
20import Foreign.ForeignPtr
23import Foreign.ForeignPtr
21import Foreign.Marshal.Alloc
24import Foreign.Marshal.Alloc
22
25
23−import Data.Attempt
26+import Control.Monad.Failure
27+import Data.Typeable (Typeable)
28+import Control.Exception (Exception)
24
29
25data ParserStruct
30data ParserStruct
26type Parser = Ptr ParserStruct
31type Parser = Ptr ParserStruct
@@ -71,12 +76,21 @@ foreign import ccall unsafe "yaml_event_delete"
71foreign import ccall "print_parser_error"
76foreign import ccall "print_parser_error"
72 c_print_parser_error :: Parser -> IO ()
77 c_print_parser_error :: Parser -> IO ()
73
78
74−parserParseOne :: Parser -> IO (Attempt Event)
79+data YamlException =
80+ YamlParserException String
81+ | YamlEmitterException String
82+ deriving (Show, Typeable)
83+instance Exception YamlException
84+
85+parserParseOne :: MonadFailure YamlException m
86+ => Parser
87+ -> IO (m Event)
75parserParseOne parser = withEventRaw $ \er -> do
88parserParseOne parser = withEventRaw $ \er -> do
76 res <- c_yaml_parser_parse parser er
89 res <- c_yaml_parser_parse parser er
77 event <-
90 event <-
78 if res == 0
91 if res == 0
79− then c_print_parser_error parser >> return (failureString "yaml_parser_parse failed") -- FIXME get the actual error message
92+ then c_print_parser_error parser
93+ >> return (failure $ YamlParserException "FIXME")
80 else return `fmap` getEvent er
94 else return `fmap` getEvent er
81 c_yaml_event_delete er
95 c_yaml_event_delete er
82 return event
96 return event
@@ -140,19 +154,29 @@ getEvent er = do
140 YamlMappingStartEvent -> return EventMappingStart
154 YamlMappingStartEvent -> return EventMappingStart
141 YamlMappingEndEvent -> return EventMappingEnd
155 YamlMappingEndEvent -> return EventMappingEnd
142
156
143−parserParse :: Parser -> IO (Attempt [Event])
157+data YAttempt v = YSuccess v | YFailure YamlException -- FIXME use c-m-e?
158+instance Monad YAttempt where
159+ return = YSuccess
160+ YSuccess v >>= f = f v
161+ YFailure e >>= _ = YFailure e
162+instance MonadFailure YamlException YAttempt where
163+ failure = YFailure
164+
165+parserParse :: MonadFailure YamlException m
166+ => Parser
167+ -> IO (m [Event])
144parserParse parser = do
168parserParse parser = do
145 event' <- parserParseOne parser
169 event' <- parserParseOne parser
146 case event' of
170 case event' of
147− Failure e -> return $ Failure e
171+ YFailure e -> return $ failure e
148− Success event ->
172+ YSuccess event ->
149 case event of
173 case event of
150− EventStreamEnd -> return $ Success [event]
174+ EventStreamEnd -> return $ return [event]
151 _ -> do
175 _ -> do
152 rest <- parserParse parser
176 rest <- parserParse parser
153 case rest of
177 case rest of
154− Failure e -> return $ Failure e
178+ YFailure e -> return $ failure e
155− Success rest' -> return $ Success $ event : rest'
179+ YSuccess rest' -> return $ return $ event : rest'
156
180
157-- Emitter
181-- Emitter
158
182
@@ -181,22 +205,26 @@ foreign import ccall unsafe "get_buffer_buff"
181foreign import ccall unsafe "get_buffer_used"
205foreign import ccall unsafe "get_buffer_used"
182 c_get_buffer_used :: Buffer -> IO CULong
206 c_get_buffer_used :: Buffer -> IO CULong
183
207
208+withBuffer :: MonadFailure YamlException m
209+ => (Buffer -> IO (YAttempt ()))
184−withBuffer :: (Buffer -> IO (Attempt ())) -> IO (Attempt B.ByteString)
210+ -> IO (m B.ByteString)
185withBuffer f = allocaBytes bufferSize $ \b -> do
211withBuffer f = allocaBytes bufferSize $ \b -> do
186 c_buffer_init b
212 c_buffer_init b
187 aRes <- f b
213 aRes <- f b
188 case aRes of
214 case aRes of
189− Failure e -> return $ Failure e
215+ YFailure e -> return $ failure e
190− Success () -> do
216+ YSuccess () -> do
191 ptr' <- c_get_buffer_buff b
217 ptr' <- c_get_buffer_buff b
192 len <- c_get_buffer_used b
218 len <- c_get_buffer_used b
193 fptr <- newForeignPtr_ $ castPtr ptr'
219 fptr <- newForeignPtr_ $ castPtr ptr'
194− return $ Success $ B.fromForeignPtr fptr 0 $ fromIntegral len
220+ return $ return $ B.fromForeignPtr fptr 0 $ fromIntegral len
195
221
196foreign import ccall unsafe "my_emitter_set_output"
222foreign import ccall unsafe "my_emitter_set_output"
197 c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
223 c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
198
224
225+withEmitter :: MonadFailure YamlException m
226+ => (Emitter -> IO (YAttempt ()))
199−withEmitter :: (Emitter -> IO (Attempt ())) -> IO (Attempt B.ByteString)
227+ -> IO (m B.ByteString)
200withEmitter f = allocaBytes emitterSize $ \e -> do
228withEmitter f = allocaBytes emitterSize $ \e -> do
201 _res <- c_yaml_emitter_initialize e
229 _res <- c_yaml_emitter_initialize e
202 -- FIXME check res
230 -- FIXME check res
@@ -212,12 +240,16 @@ foreign import ccall unsafe "yaml_emitter_emit"
212foreign import ccall unsafe "print_emitter_error"
240foreign import ccall unsafe "print_emitter_error"
213 c_print_emitter_error :: Emitter -> IO ()
241 c_print_emitter_error :: Emitter -> IO ()
214
242
215−emitEvents :: Emitter -> [Event] -> IO (Attempt ())
243+emitEvents :: MonadFailure YamlException m
244+ => Emitter
245+ -> [Event]
246+ -> IO (m ())
216−emitEvents _ [] = return $ Success ()
247+emitEvents _ [] = return $ return ()
217emitEvents emitter (e:rest) = do
248emitEvents emitter (e:rest) = do
218 res <- toEventRaw e $ c_yaml_emitter_emit emitter
249 res <- toEventRaw e $ c_yaml_emitter_emit emitter
219 if res == 0
250 if res == 0
220− then c_print_emitter_error emitter >> return (failureString "yaml_emitter_emit failed") -- FIXME get the actual error message
251+ then c_print_emitter_error emitter
252+ >> return (failure $ YamlEmitterException "FIXME")
221 else emitEvents emitter rest
253 else emitEvents emitter rest
222
254
223foreign import ccall unsafe "yaml_stream_start_event_initialize"
255foreign import ccall unsafe "yaml_stream_start_event_initialize"
Text/Yaml.hs+71−53
@@ -1,6 +1,7 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE CPP #-}
4---------------------------------------------------------
5---------------------------------------------------------
5--
6--
6-- Module : Text.Yaml
7-- Module : Text.Yaml
@@ -21,84 +22,97 @@ module Text.Yaml
21 , encodeFile
22 , encodeFile
22 , decode
23 , decode
23 , decodeFile
24 , decodeFile
25+#if TEST
24 , testSuite
26 , testSuite
27+#endif
25 ) where
28 ) where
26
29
27import Prelude hiding (readList)
30import Prelude hiding (readList)
28import Text.Libyaml
31import Text.Libyaml
29import qualified Data.ByteString as B
32import qualified Data.ByteString as B
30−import Data.ByteString.Class
33+import qualified Data.ByteString.Lazy as BL
31import Data.Object
34import Data.Object
32−import Data.Object.Raw
35+import Data.Object.Text
33import System.IO.Unsafe
36import System.IO.Unsafe
34−import Control.Arrow (first, (***))
37+import Control.Arrow (first)
35−import Control.Monad (replicateM, liftM)
38+import Control.Monad (liftM, join)
36import Control.Monad.Trans
39import Control.Monad.Trans
37import Control.Monad.Attempt
40import Control.Monad.Attempt
41+import Data.Convertible
38
42
43+import Data.Text.Lazy (Text)
44+import qualified Data.Text.Lazy as LT
45+import qualified Data.Text.Lazy.Encoding as LTE
46+
47+#if TEST
39import Test.Framework (testGroup, Test)
48import Test.Framework (testGroup, Test)
40import Test.Framework.Providers.HUnit
49import Test.Framework.Providers.HUnit
41import Test.Framework.Providers.QuickCheck (testProperty)
50import Test.Framework.Providers.QuickCheck (testProperty)
42import Test.HUnit hiding (Test, path)
51import Test.HUnit hiding (Test, path)
43import Test.QuickCheck
52import Test.QuickCheck
53+#endif
44
54
45−import Control.Exception
55+encode :: (ConvertSuccess B.ByteString a, ToObject o Text Text) => o -> a
46−
47−encode :: (StrictByteString bs, ToObject o Raw Raw) => o -> bs
48encode = unsafePerformIO . encode'
56encode = unsafePerformIO . encode'
49
57
50−decode :: (StrictByteString bs, FromObject o Raw Raw, MonadFailure SomeException m)
58+decode :: (ConvertSuccess a B.ByteString,
51− => bs
59+ MonadFailure YamlException m)
52− -> m o
60+ => a
61+ -> m TextObject
53−decode bs = unsafePerformIO $ do
62+decode = unsafePerformIO . decode'
54− a <- runAttemptT $ decode' bs -- FIXME
55− case a of
56− Success s -> return $ return s
57− Failure e -> return $ failure e
58
63
59−encodeFile :: ToObject o Raw Raw => FilePath -> o -> IO ()
64+encodeFile :: ToObject o Text Text => FilePath -> o -> IO ()
60−encodeFile path o = encode' o >>= B.writeFile path
65+encodeFile path o = encode' o >>= ltWriteFile path
61
66
62−decodeFile :: (FromObject o Raw Raw, MonadFailure SomeException m, MonadIO m)
63− => FilePath
67+ltWriteFile :: FilePath -> Text -> IO ()
64− -> m o
68+ltWriteFile fp = BL.writeFile fp . LTE.encodeUtf8
65−decodeFile path = liftIO (B.readFile path) >>= decode'
66
69
67−encode' :: (StrictByteString bs, ToObject o Raw Raw) => o -> IO bs
70+decodeFile :: (MonadFailure YamlException m,
71+ MonadIO m)
72+ => FilePath
73+ -> m TextObject
74+decodeFile path = do
75+ contents <- liftIO (ltReadFile path)
76+ join $ liftIO $ decode' contents
77+
78+ltReadFile :: FilePath -> IO Text
79+ltReadFile = fmap LTE.decodeUtf8 . BL.readFile
80+
81+encode' :: (ConvertSuccess B.ByteString a,
82+ ToObject o Text Text)
83+ => o
84+ -> IO a
68encode' o =
85encode' o =
69 let events = objectToEvents $ toObject o
86 let events = objectToEvents $ toObject o
70 result = withEmitter $ flip emitEvents events
87 result = withEmitter $ flip emitEvents events
71− in fromStrictByteString `fmap` joinAttempt result
88+ in convertSuccess `fmap` joinAttempt result
72
89
73−decode' :: (StrictByteString bs, FromObject o Raw Raw, MonadIO m,
90+decode' :: (ConvertSuccess a B.ByteString,
74− MonadFailure SomeException m)
91+ MonadFailure YamlException m
75− => bs
92+ )
76− -> m o
93+ => a
94+ -> IO (m TextObject)
77decode' bs = do
95decode' bs = do
78− events <- liftIO $ withParser (toStrictByteString bs) parserParse
96+ events <- withParser (convertSuccess bs) parserParse
79− attempt failure' (myFA . fromObject . eventsToRawObject) events
97+ return $ liftM eventsToTextObject events
80− where
98+
81− myFA = attempt failure' return
82− failure' :: (MonadFailure SomeException m, Exception e) => e -> m a
83− failure' = failure . SomeException
84−
85−objectToEvents :: RawObject -> [Event]
99+objectToEvents :: TextObject -> [Event]
86objectToEvents y = concat
100objectToEvents y = concat
87 [ [EventStreamStart, EventDocumentStart]
101 [ [EventStreamStart, EventDocumentStart]
88 , writeSingle y
102 , writeSingle y
89 , [EventDocumentEnd, EventStreamEnd]] where
103 , [EventDocumentEnd, EventStreamEnd]] where
90− writeSingle :: RawObject -> [Event]
104+ writeSingle :: TextObject -> [Event]
91− writeSingle (Scalar (Raw bs)) = [EventScalar $ toStrictByteString bs]
105+ writeSingle (Scalar text) = [EventScalar $ convertSuccess text]
92 writeSingle (Sequence ys) =
106 writeSingle (Sequence ys) =
93 (EventSequenceStart : concatMap writeSingle ys)
107 (EventSequenceStart : concatMap writeSingle ys)
94 ++ [EventSequenceEnd]
108 ++ [EventSequenceEnd]
95 writeSingle (Mapping pairs) =
109 writeSingle (Mapping pairs) =
96 EventMappingStart : concatMap writePair pairs ++ [EventMappingEnd]
110 EventMappingStart : concatMap writePair pairs ++ [EventMappingEnd]
97− writePair :: (Raw, RawObject) -> [Event]
111+ writePair :: (Text, TextObject) -> [Event]
98− writePair (Raw k, v) = EventScalar (fromLazyByteString k) : writeSingle v
112+ writePair (k, v) = EventScalar (convertSuccess k) : writeSingle v
99
113
100−eventsToRawObject :: [Event] -> RawObject
114+eventsToTextObject :: [Event] -> TextObject
101−eventsToRawObject = fst . readSingle . dropWhile isIgnored where
115+eventsToTextObject = fst . readSingle . dropWhile isIgnored where
102 isIgnored EventAlias = False
116 isIgnored EventAlias = False
103 isIgnored (EventScalar _) = False
117 isIgnored (EventScalar _) = False
104 isIgnored EventSequenceStart = False
118 isIgnored EventSequenceStart = False
@@ -106,37 +120,40 @@ eventsToRawObject = fst . readSingle . dropWhile isIgnored where
106 isIgnored EventMappingStart = False
120 isIgnored EventMappingStart = False
107 isIgnored EventMappingEnd = False
121 isIgnored EventMappingEnd = False
108 isIgnored _ = True
122 isIgnored _ = True
109− readSingle :: [Event] -> (RawObject, [Event])
123+ readSingle :: [Event] -> (TextObject, [Event])
110 readSingle [] = error "readSingle: no more events"
124 readSingle [] = error "readSingle: no more events"
111 readSingle (EventScalar bs:rest) =
125 readSingle (EventScalar bs:rest) =
112− (Scalar $ Raw $ toLazyByteString bs, rest)
126+ (Scalar $ convertSuccess bs, rest)
113 readSingle (EventSequenceStart:rest) = readList [] rest
127 readSingle (EventSequenceStart:rest) = readList [] rest
114 readSingle (EventMappingStart:rest) = readMap [] rest
128 readSingle (EventMappingStart:rest) = readMap [] rest
115 readSingle (x:_) = error $ "readSingle: " ++ show x
129 readSingle (x:_) = error $ "readSingle: " ++ show x
116− readList :: [RawObject] -> [Event] -> (RawObject, [Event])
130+ readList :: [TextObject] -> [Event] -> (TextObject, [Event])
117 readList nodes (EventSequenceEnd:rest) =
131 readList nodes (EventSequenceEnd:rest) =
118 (Sequence $ reverse nodes, rest)
132 (Sequence $ reverse nodes, rest)
119 readList nodes events =
133 readList nodes events =
120 let (next, rest) = readSingle events
134 let (next, rest) = readSingle events
121 in readList (next : nodes) rest
135 in readList (next : nodes) rest
122− readMap :: [(B.ByteString, RawObject)]
136+ readMap :: [(B.ByteString, TextObject)]
123 -> [Event]
137 -> [Event]
124− -> (RawObject, [Event])
138+ -> (TextObject, [Event])
125 readMap pairs (EventMappingEnd:rest) =
139 readMap pairs (EventMappingEnd:rest) =
126− (Mapping $ map (first $ Raw . toLazyByteString) $ reverse pairs, rest)
140+ (Mapping $ map (first convertSuccess) $ reverse pairs, rest)
127 readMap pairs (EventScalar bs:events) =
141 readMap pairs (EventScalar bs:events) =
128 let (next, rest) = readSingle events
142 let (next, rest) = readSingle events
129− in readMap ((fromStrictByteString bs, next) : pairs) rest
143+ in readMap ((bs, next) : pairs) rest
130 readMap _ (e:_) = error $ "Unexpected event in readMap: " ++ show e
144 readMap _ (e:_) = error $ "Unexpected event in readMap: " ++ show e
131 readMap _ [] = error "Unexpected empty event list in readMap"
145 readMap _ [] = error "Unexpected empty event list in readMap"
132
146
133newtype MyString = MyString String
147newtype MyString = MyString String
134 deriving (Eq, Show)
148 deriving (Eq, Show)
135−instance ToScalar MyString Raw where
149+instance ConvertAttempt MyString Text where
136− toScalar (MyString s) = toScalar s
150+ convertAttempt = return . convertSuccess
151+instance ConvertSuccess MyString Text where
152+ convertSuccess (MyString s) = convertSuccess s
137−instance FromScalar MyString Raw where
153+instance ConvertAttempt Text MyString where
138− fromScalar raw = MyString `liftM` fromScalar raw
154+ convertAttempt raw = MyString `liftM` convertAttempt raw
139−
155+
156+#if TEST
140propEncodeDecode :: Object MyString MyString -> Bool
157propEncodeDecode :: Object MyString MyString -> Bool
141propEncodeDecode o = fromAttempt (decode (encode o :: B.ByteString))
158propEncodeDecode o = fromAttempt (decode (encode o :: B.ByteString))
142 == Just o
159 == Just o
@@ -174,3 +191,4 @@ instance Arbitrary MyString where
174 size <- arbitrary
191 size <- arbitrary
175 s <- replicateM (size `mod` 5) $ elements ['A'..'Z']
192 s <- replicateM (size `mod` 5) $ elements ['A'..'Z']
176 return $! MyString s
193 return $! MyString s
194+#endif
yaml.cabal+18−8
@@ -15,22 +15,22 @@ extra-source-files: c/helper.h,
15 c/yaml_private.h,
15 c/yaml_private.h,
16 c/yaml.h
16 c/yaml.h
17
17
18+flag buildtests
19+ description: Build the executable to run unit tests
20+ default: False
21+
18library
22library
19 build-depends: base >= 4 && < 5,
23 build-depends: base >= 4 && < 5,
20− bytestring-class,
21 data-object == 0.2.0,
24 data-object == 0.2.0,
22 bytestring >= 0.9.1.4 && < 1,
25 bytestring >= 0.9.1.4 && < 1,
23 haskell98,
26 haskell98,
24− test-framework,
25− test-framework-quickcheck,
26− test-framework-hunit,
27− HUnit,
28 time,
27 time,
29− QuickCheck >= 1 && < 2,
28+ attempt >= 0.0.2,
30− attempt,
31 safe-failure,
29 safe-failure,
32 transformers >= 0.1.4.0,
30 transformers >= 0.1.4.0,
33− control-monad-failure
31+ control-monad-failure >= 0.4,
32+ text >= 0.5,
33+ convertible >= 1.2.0
34 exposed-modules: Text.Yaml
34 exposed-modules: Text.Yaml
35 other-modules: Text.Libyaml
35 other-modules: Text.Libyaml
36 ghc-options: -Wall
36 ghc-options: -Wall
@@ -46,6 +46,16 @@ library
46 include-dirs: c
46 include-dirs: c
47
47
48executable yamltest
48executable yamltest
49+ if flag(buildtests)
50+ Buildable: True
51+ cpp-options: -DTEST
52+ build-depends: test-framework,
53+ test-framework-quickcheck,
54+ test-framework-hunit,
55+ HUnit,
56+ QuickCheck >= 1 && < 2
57+ else
58+ Buildable: False
49 ghc-options: -Wall
59 ghc-options: -Wall
50 c-sources: c/helper.c,
60 c-sources: c/helper.c,
51 c/api.c,
61 c/api.c,