git.iko.soy/typeable/yaml
on master help sign in
YamlObject adds tag and style information
6b00934Michael Snoyman
Data/Object/Yaml.hsnew file+148
compare with master
unifiedsplit
@@ -0,0 +1,148 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE DeriveDataTypeable #-}
5+module Data.Object.Yaml
6+ ( -- * The event stream
7+ Event (..)
8+ , Style (..)
9+ -- * 'YamlObject' definition
10+ , Yaml (..)
11+ , YamlObject
12+ -- * Performing conversions
13+ , eventsToYamlObject
14+ -- * Exceptions
15+ , YamlException (..)
16+ ) where
17+
18+import Data.ByteString (ByteString)
19+import Data.Object
20+import Data.Object.Text
21+import Data.Convertible.Text
22+import Data.Attempt
23+
24+import Data.Typeable (Typeable)
25+import Control.Exception (Exception)
26+
27+data Event =
28+ EventNone
29+ | EventStreamStart
30+ | EventStreamEnd
31+ | EventDocumentStart
32+ | EventDocumentEnd
33+ | EventAlias
34+ | EventScalar ByteString ByteString Style
35+ | EventSequenceStart
36+ | EventSequenceEnd
37+ | EventMappingStart
38+ | EventMappingEnd
39+ deriving (Show, Eq)
40+
41+data Style = Any
42+ | Plain
43+ | SingleQuoted
44+ | DoubleQuoted
45+ | Literal
46+ | Folded
47+ deriving (Show, Eq, Enum, Bounded, Ord)
48+
49+data Yaml = Yaml
50+ { value :: ByteString
51+ , tag :: String
52+ , style :: Style
53+ }
54+instance ConvertSuccess Yaml Event where
55+ convertSuccess (Yaml v t s) = EventScalar v (convertSuccess t) s
56+instance ConvertSuccess Yaml Text where
57+ convertSuccess = convertSuccess . value
58+instance ConvertSuccess Text Yaml where
59+ convertSuccess t = Yaml (convertSuccess t) "" Any
60+
61+type YamlObject = Object Yaml Yaml
62+
63+data YamlException =
64+ YamlParserException
65+ { parserProblem :: String
66+ , parserContext :: String
67+ , parserOffset :: Int
68+ }
69+ | YamlEmitterException { emitterProblem :: String }
70+ | YamlInvalidEventStreamBeginning [Event]
71+ | YamlInvalidEventStreamEnd [Event]
72+ | YamlPrematureEventStreamEnd
73+ | YamlNonScalarKey
74+ | YamlInvalidStartingEvent Event
75+ deriving (Show, Typeable)
76+instance Exception YamlException
77+
78+-- Emit a YamlObject to an event stream
79+instance ConvertSuccess (Object Yaml Yaml) [Event] where
80+ convertSuccess o = EventStreamStart
81+ : EventDocumentStart
82+ : helper o [EventDocumentEnd, EventStreamEnd] where
83+ helper :: YamlObject -> [Event] -> [Event]
84+ helper (Scalar y) rest = convertSuccess y : rest
85+ helper (Sequence ys) rest =
86+ EventSequenceStart
87+ : foldr ($) (EventSequenceEnd : rest) (map helper ys)
88+ helper (Mapping pairs) rest =
89+ EventMappingStart
90+ : foldr ($) (EventMappingEnd : rest) (map helperPairs pairs)
91+ helperPairs :: (Yaml, YamlObject) -> [Event] -> [Event]
92+ helperPairs (k, v) rest = convertSuccess k : helper v rest
93+
94+-- Parse a YamlObject from an event stream
95+eventsToYamlObject :: MonadFailure YamlException m
96+ => [Event]
97+ -> m YamlObject
98+eventsToYamlObject (EventStreamStart:EventDocumentStart:events) = h1 events
99+ where
100+ h1 :: MonadFailure YamlException m => [Event] -> m YamlObject
101+ h1 es = do
102+ (yo, es') <- h2 es
103+ case es' of
104+ [EventDocumentEnd, EventStreamEnd] -> return yo
105+ _ -> failure $ YamlInvalidEventStreamEnd es'
106+ h2 :: MonadFailure YamlException m
107+ => [Event]
108+ -> m (YamlObject, [Event])
109+ h2 [] = failure YamlPrematureEventStreamEnd
110+ h2 (EventScalar v t s:rest) =
111+ return (Scalar $ Yaml v (convertSuccess t) s, rest)
112+ h2 (EventSequenceStart:es) = do
113+ (yos, rest) <- readSeq id es
114+ return (Sequence yos, rest)
115+ h2 (EventMappingStart:es) = do
116+ (ypairs, rest) <- readMap id es
117+ return (Mapping ypairs, rest)
118+ h2 (e:_) = failure $ YamlInvalidStartingEvent e
119+
120+ readSeq :: MonadFailure YamlException m
121+ => ([YamlObject] -> [YamlObject])
122+ -> [Event]
123+ -> m ([YamlObject], [Event])
124+ readSeq _ [] = failure YamlPrematureEventStreamEnd
125+ readSeq f (EventSequenceEnd:rest) = return (f [], rest)
126+ readSeq f es = do
127+ (next, rest) <- h2 es
128+ readSeq (f . ((:) next)) rest
129+
130+ readMap :: MonadFailure YamlException m
131+ => ([(Yaml, YamlObject)] -> [(Yaml, YamlObject)])
132+ -> [Event]
133+ -> m ([(Yaml, YamlObject)], [Event])
134+ readMap _ [] = failure YamlPrematureEventStreamEnd
135+ readMap f (EventMappingEnd:rest) = return (f [], rest)
136+ readMap f es = do
137+ (key, rest) <- h2 es
138+ key' <- case key of
139+ Scalar y -> return y
140+ _ -> failure YamlNonScalarKey
141+ (val, rest') <- h2 rest
142+ readMap (f . ((:) (key', val))) rest'
143+eventsToYamlObject e = failure $ YamlInvalidEventStreamBeginning e
144+
145+instance ConvertSuccess (Object Yaml Yaml) (Object Text Text) where
146+ convertSuccess = mapKeysValues convertSuccess convertSuccess
147+instance ConvertSuccess (Object Text Text) (Object Yaml Yaml) where
148+ convertSuccess = mapKeysValues convertSuccess convertSuccess
Text/Libyaml.hs+27−38
@@ -7,14 +7,12 @@
7{-# INCLUDE <yaml.h> #-}
7{-# INCLUDE <yaml.h> #-}
8{-# INCLUDE <helper.h> #-}
8{-# INCLUDE <helper.h> #-}
9module Text.Libyaml
9module Text.Libyaml
10−{-
10+ ( YamlException (..)
11− (
12− Event (..)
13− , parserParse
14− , withParser
15− , emitEvents
16 , withEmitter
11 , withEmitter
12+ , emitEvents
13+ , withParser
14+ , parserParse
17− )-} where
15+ ) where
18
16
19import qualified Data.ByteString.Internal as B
17import qualified Data.ByteString.Internal as B
20import Control.Monad
18import Control.Monad
@@ -24,14 +22,12 @@ import Foreign.ForeignPtr
24import Foreign.Marshal.Alloc
22import Foreign.Marshal.Alloc
25
23
26import Control.Failure
24import Control.Failure
27−import Data.Typeable (Typeable)
28−import Control.Exception (Exception)
29
25
30import Data.Convertible.Text
26import Data.Convertible.Text
31−import Data.Text.Lazy (Text)
32−import Data.Object.Text ()
33import Control.Applicative
27import Control.Applicative
34
28
29+import Data.Object.Yaml hiding (style, value)
30+
35data ParserStruct
31data ParserStruct
36type Parser = Ptr ParserStruct
32type Parser = Ptr ParserStruct
37parserSize :: Int
33parserSize :: Int
@@ -87,22 +83,12 @@ foreign import ccall "get_parser_error_context"
87foreign import ccall unsafe "get_parser_error_offset"
83foreign import ccall unsafe "get_parser_error_offset"
88 c_get_parser_error_offset :: Parser -> IO CULong
84 c_get_parser_error_offset :: Parser -> IO CULong
89
85
90−data YamlException =
91− YamlParserException
92− { parserProblem :: String
93− , parserContext :: String
94− , parserOffset :: Int
95− }
96− | YamlEmitterException { emitterProblem :: String }
97− deriving (Show, Typeable)
98−instance Exception YamlException
99−
100makeString :: (a -> IO (Ptr CUChar)) -> a -> IO String
86makeString :: (a -> IO (Ptr CUChar)) -> a -> IO String
101makeString f a = do
87makeString f a = do
102 cchar <- castPtr `fmap` f a
88 cchar <- castPtr `fmap` f a
103 len <- fromIntegral `fmap` B.c_strlen cchar
89 len <- fromIntegral `fmap` B.c_strlen cchar
104 bs <- B.create len $ \dest -> B.memcpy dest (castPtr cchar) (fromIntegral len)
90 bs <- B.create len $ \dest -> B.memcpy dest (castPtr cchar) (fromIntegral len)
105− return $ (convertSuccess :: Text -> String) $ convertSuccess bs
91+ return $ convertSuccess bs
106
92
107parserParseOne :: MonadFailure YamlException m
93parserParseOne :: MonadFailure YamlException m
108 => Parser
94 => Parser
@@ -122,20 +108,6 @@ parserParseOne parser = withEventRaw $ \er -> do
122 c_yaml_event_delete er
108 c_yaml_event_delete er
123 return event
109 return event
124
110
125−data Event =
126− EventNone
127− | EventStreamStart
128− | EventStreamEnd
129− | EventDocumentStart
130− | EventDocumentEnd
131− | EventAlias
132− | EventScalar B.ByteString
133− | EventSequenceStart
134− | EventSequenceEnd
135− | EventMappingStart
136− | EventMappingEnd
137− deriving (Show)
138−
139data EventType = YamlNoEvent
111data EventType = YamlNoEvent
140 | YamlStreamStartEvent
112 | YamlStreamStartEvent
141 | YamlStreamEndEvent
113 | YamlStreamEndEvent
@@ -158,6 +130,15 @@ foreign import ccall unsafe "get_scalar_value"
158foreign import ccall unsafe "get_scalar_length"
130foreign import ccall unsafe "get_scalar_length"
159 c_get_scalar_length :: EventRaw -> IO CULong
131 c_get_scalar_length :: EventRaw -> IO CULong
160
132
133+foreign import ccall unsafe "get_scalar_tag"
134+ c_get_scalar_tag :: EventRaw -> IO (Ptr CUChar)
135+
136+foreign import ccall unsafe "get_scalar_tag_len"
137+ c_get_scalar_tag_len :: EventRaw -> IO CULong
138+
139+foreign import ccall unsafe "get_scalar_style"
140+ c_get_scalar_style :: EventRaw -> IO CInt
141+
161getEvent :: EventRaw -> IO Event
142getEvent :: EventRaw -> IO Event
162getEvent er = do
143getEvent er = do
163 et <- c_get_event_type er
144 et <- c_get_event_type er
@@ -171,11 +152,19 @@ getEvent er = do
171 YamlScalarEvent -> do
152 YamlScalarEvent -> do
172 yvalue <- c_get_scalar_value er
153 yvalue <- c_get_scalar_value er
173 ylen <- c_get_scalar_length er
154 ylen <- c_get_scalar_length er
155+ ytag <- c_get_scalar_tag er
156+ ytag_len <- c_get_scalar_tag_len er
157+ ystyle <- c_get_scalar_style er
158+ let ytag_len' = fromEnum ytag_len
174 let yvalue' = castPtr yvalue
159 let yvalue' = castPtr yvalue
160+ let ytag' = castPtr ytag
175 let ylen' = fromEnum ylen
161 let ylen' = fromEnum ylen
176 let ylen'' = toEnum $ fromEnum ylen
162 let ylen'' = toEnum $ fromEnum ylen
177 bs <- B.create ylen' $ \dest -> B.memcpy dest yvalue' ylen''
163 bs <- B.create ylen' $ \dest -> B.memcpy dest yvalue' ylen''
164+ tagbs <- B.create ytag_len'
165+ $ \dest -> B.memcpy dest ytag' (toEnum ytag_len')
166+ let style = toEnum $ fromEnum ystyle
178− return $ EventScalar bs
167+ return $ EventScalar bs tagbs style
179 YamlSequenceStartEvent -> return EventSequenceStart
168 YamlSequenceStartEvent -> return EventSequenceStart
180 YamlSequenceEndEvent -> return EventSequenceEnd
169 YamlSequenceEndEvent -> return EventSequenceEnd
181 YamlMappingStartEvent -> return EventMappingStart
170 YamlMappingStartEvent -> return EventMappingStart
@@ -346,7 +335,7 @@ toEventRaw e f = withEventRaw $ \er -> do
346 c_simple_document_start er
335 c_simple_document_start er
347 EventDocumentEnd ->
336 EventDocumentEnd ->
348 c_yaml_document_end_event_initialize er 1
337 c_yaml_document_end_event_initialize er 1
349− EventScalar bs -> do
338+ EventScalar bs _tag _style -> do -- FIXME
350 let (fvalue, offset, len) = B.toForeignPtr bs
339 let (fvalue, offset, len) = B.toForeignPtr bs
351 withForeignPtr fvalue $ \value -> do
340 withForeignPtr fvalue $ \value -> do
352 let value' = value `plusPtr` offset
341 let value' = value `plusPtr` offset
Text/Yaml.hs+100−187
@@ -2,6 +2,7 @@
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE CPP #-}
4{-# LANGUAGE CPP #-}
5+{-# LANGUAGE PackageImports #-}
5---------------------------------------------------------
6---------------------------------------------------------
6--
7--
7-- Module : Text.Yaml
8-- Module : Text.Yaml
@@ -20,21 +21,18 @@ module Text.Yaml
20 (
21 (
21 -- * Exceptions
22 -- * Exceptions
22 YamlException (..)
23 YamlException (..)
23− ,
24+ -- * Converting to/from 'YamlObject's
25+ , encodeYaml'
26+ , decodeYaml'
27+ , encodeYaml
28+ , decodeYaml
29+ , decodeYamlSuccess
24 -- * Converting to/from 'TextObject's
30 -- * Converting to/from 'TextObject's
25− encodeText
31+ , encodeText'
26− , encodeToText
32+ , decodeText'
33+ , encodeText
27 , decodeText
34 , decodeText
28− , decodeFromText
35+ , decodeTextSuccess
29− , decodeFromTextWrap
30− -- * Convert to/from 'ScalarObejct's
31− , encodeScalar
32− , decodeScalar
33− -- * Files
34− , encodeFile
35− , encodeFileToText
36− , decodeFile
37− , decodeFileFromTextWrap
38#if TEST
36#if TEST
39 , testSuite
37 , testSuite
40#endif
38#endif
@@ -42,20 +40,17 @@ module Text.Yaml
42
40
43import Prelude hiding (readList)
41import Prelude hiding (readList)
44import Text.Libyaml
42import Text.Libyaml
45−import qualified Data.ByteString as B
43+import Data.ByteString (ByteString)
46−import Data.Object
47import Data.Object.Text
44import Data.Object.Text
48−import Data.Object.Scalar
49import System.IO.Unsafe
45import System.IO.Unsafe
50−import Control.Arrow (first)
46+import Control.Monad (join)
51−import Control.Monad (liftM, join)
52−import Control.Monad.Trans
53import Data.Convertible.Text
47import Data.Convertible.Text
54import Data.Attempt
48import Data.Attempt
55
49
56−import Data.Text.Lazy (Text)
50+import Data.Object.Yaml
57
51
58#if TEST
52#if TEST
53+import Data.Object
59import Test.Framework (testGroup, Test)
54import Test.Framework (testGroup, Test)
60import Test.Framework.Providers.HUnit
55import Test.Framework.Providers.HUnit
61import Test.Framework.Providers.QuickCheck (testProperty)
56import Test.Framework.Providers.QuickCheck (testProperty)
@@ -63,187 +58,101 @@ import Test.HUnit hiding (Test, path)
63import Test.QuickCheck
58import Test.QuickCheck
64
59
65import Control.Monad (replicateM)
60import Control.Monad (replicateM)
66−import Control.Arrow ((***))
67import qualified Data.Text.Lazy as LT
61import qualified Data.Text.Lazy as LT
68import qualified Data.ByteString.Lazy as BL
62import qualified Data.ByteString.Lazy as BL
63+import qualified Data.ByteString as B
64+import Data.Attempt
65+import Control.Arrow ((***))
69#endif
66#endif
70
67
71-- Low level, non-exported functions
68-- Low level, non-exported functions
72encode' :: MonadFailure YamlException m
69encode' :: MonadFailure YamlException m
73− => TextObject
70+ => YamlObject
74− -> IO (m B.ByteString)
71+ -> IO (m ByteString)
75−encode' o = do
76− let events = objectToEvents o
77− result <- withEmitter $ flip emitEvents events
72+encode' = withEmitter . flip emitEvents . convertSuccess
78− return $ do
79− result' <- result
80− return result'
81
73
82decode' :: MonadFailure YamlException m
74decode' :: MonadFailure YamlException m
83− => B.ByteString
75+ => ByteString
84− -> IO (m TextObject)
76+ -> IO (m YamlObject)
85decode' bs = do
77decode' bs = do
86− events <- withParser (convertSuccess bs) parserParse
78+ events <- withParser bs parserParse
87− return $ liftM eventsToTextObject events
79+ return $ events >>= eventsToYamlObject
88−
80+
89−-- Text API
81+-- Convert to YamlObject directly
90−-- FIXME: this *should* be in a MonadFailure
82+encodeYaml' :: YamlObject -> ByteString
91−
83+encodeYaml' = unsafePerformIO . join . encode'
92−-- FIXME: I think the To and From below are backwards. Maybe just say convert?
84+
93−encodeText :: ConvertSuccess B.ByteString a
85+decodeYaml' :: MonadFailure YamlException m => ByteString -> m YamlObject
94− => TextObject
86+decodeYaml' = unsafePerformIO . decode'
95− -> a
87+
96−encodeText = convertSuccess . unsafePerformIO . join . encode'
88+-- Convert to YamlObject conversions
97−
89+encodeYaml :: ConvertSuccess x YamlObject => x -> ByteString
98−encodeToText :: (ConvertSuccess B.ByteString a, ToObject x Text Text)
90+encodeYaml = encodeYaml' . convertSuccess
99− => x
91+
100− -> a
92+decodeYaml :: ( ConvertAttempt YamlObject x
101−encodeToText = convertSuccess . unsafePerformIO . join . encode' . toTextObject
93+ , Failure ConversionException m
102−
103−decodeText :: (ConvertSuccess a B.ByteString,
104− MonadFailure YamlException m)
94+ , MonadFailure YamlException m
105− => a
95+ )
106− -> m TextObject
96+ => ByteString
107−decodeText = unsafePerformIO . decode' . convertSuccess
97+ -> m x
108−
98+decodeYaml b = decodeYaml' b >>= convertAttemptWrap
109−decodeFromText :: (ConvertSuccess a B.ByteString,
99+
110− FromObject x Text Text)
100+decodeYamlSuccess :: ( ConvertSuccess YamlObject x
111− => a
101+ , MonadFailure YamlException m
112− -> Attempt x
102+ )
113−decodeFromText a = decodeText a >>= fromObject
103+ => ByteString
114−
104+ -> m x
115−decodeFromTextWrap :: (ConvertSuccess a B.ByteString,
105+decodeYamlSuccess = fmap convertSuccess . decodeYaml'
116− FromObject x Text Text,
106+
107+-- TextObjects
108+encodeText' :: TextObject -> ByteString
109+encodeText' = encodeYaml
110+
117− MonadFailure YamlException m,
111+decodeText' :: MonadFailure YamlException m => ByteString -> m TextObject
118− MonadFailure FromObjectException m
112+decodeText' = decodeYamlSuccess
119− )
113+
120− => a
114+-- TextObject conversions
121− -> m x
115+encodeText :: ConvertSuccess x TextObject => x -> ByteString
122−decodeFromTextWrap a = decodeText a >>= fromObjectWrap
116+encodeText = encodeText' . convertSuccess
123−
117+
124−-- Scalar API
118+decodeText :: ( MonadFailure YamlException m
125−-- FIXME: this *should* be in a MonadFailure...
119+ , ConvertAttempt TextObject x
126−encodeScalar :: ConvertSuccess B.ByteString a
120+ , Failure ConversionException m
127− => ScalarObject
121+ )
128− -> a
122+ => ByteString
129−encodeScalar = convertSuccess . unsafePerformIO . join . encode' . toTextObject
123+ -> m x
130−
124+decodeText bs = decodeText' bs >>= convertAttemptWrap
131−decodeScalar :: (ConvertSuccess a B.ByteString,
125+
132− MonadFailure YamlException m)
133− => a
134− -> m ScalarObject
135−decodeScalar = liftM toScalarObject . unsafePerformIO . decode' . convertSuccess
136−
137−-- File API
138−encodeFile :: (MonadIO m, MonadFailure YamlException m)
126+decodeTextSuccess :: ( MonadFailure YamlException m
139− => FilePath
140− -> TextObject
127+ , ConvertSuccess TextObject x
141− -> m ()
128+ )
142−encodeFile path o = do
129+ => ByteString
143− content <- liftIO $ encode' o
130+ -> m x
144− content' <- content
131+decodeTextSuccess = fmap convertSuccess . decodeText'
145− liftIO $ B.writeFile path content'
146−
147−encodeFileToText :: (ToObject x Text Text,
148− MonadIO m,
149− MonadFailure YamlException m
150− )
151− => FilePath
152− -> x
153− -> m ()
154−encodeFileToText fp = encodeFile fp . toTextObject
155−
156−decodeFile :: (MonadFailure YamlException m,
157− MonadIO m)
158− => FilePath
159− -> m TextObject
160−decodeFile path = do
161− contents <- liftIO $ B.readFile path
162− join $ liftIO $ decode' contents
163−
164−decodeFileFromTextWrap :: (MonadFailure YamlException m,
165− MonadFailure FromObjectException m,
166− MonadIO m,
167− FromObject x Text Text
168− )
169− => FilePath
170− -> m x
171−decodeFileFromTextWrap path = decodeFile path >>= fromObjectWrap
172−
173−-- The real worker functions
174−objectToEvents :: TextObject -> [Event]
175−objectToEvents y = concat
176− [ [EventStreamStart, EventDocumentStart]
177− , writeSingle y
178− , [EventDocumentEnd, EventStreamEnd]] where
179− writeSingle :: TextObject -> [Event]
180− writeSingle (Scalar text) = [EventScalar $ convertSuccess text]
181− writeSingle (Sequence ys) =
182− (EventSequenceStart : concatMap writeSingle ys)
183− ++ [EventSequenceEnd]
184− writeSingle (Mapping pairs) =
185− EventMappingStart : concatMap writePair pairs ++ [EventMappingEnd]
186− writePair :: (Text, TextObject) -> [Event]
187− writePair (k, v) = EventScalar (convertSuccess k) : writeSingle v
188−
189−eventsToTextObject :: [Event] -> TextObject
190−eventsToTextObject = fst . readSingle . dropWhile isIgnored where
191− isIgnored EventAlias = False
192− isIgnored (EventScalar _) = False
193− isIgnored EventSequenceStart = False
194− isIgnored EventSequenceEnd = False
195− isIgnored EventMappingStart = False
196− isIgnored EventMappingEnd = False
197− isIgnored _ = True
198− readSingle :: [Event] -> (TextObject, [Event])
199− readSingle [] = error "readSingle: no more events"
200− readSingle (EventScalar bs:rest) =
201− (Scalar $ convertSuccess bs, rest)
202− readSingle (EventSequenceStart:rest) = readList [] rest
203− readSingle (EventMappingStart:rest) = readMap [] rest
204− readSingle (x:_) = error $ "readSingle: " ++ show x
205− readList :: [TextObject] -> [Event] -> (TextObject, [Event])
206− readList nodes (EventSequenceEnd:rest) =
207− (Sequence $ reverse nodes, rest)
208− readList nodes events =
209− let (next, rest) = readSingle events
210− in readList (next : nodes) rest
211− readMap :: [(B.ByteString, TextObject)]
212− -> [Event]
213− -> (TextObject, [Event])
214− readMap pairs (EventMappingEnd:rest) =
215− (Mapping $ map (first convertSuccess) $ reverse pairs, rest)
216− readMap pairs (EventScalar bs:events) =
217− let (next, rest) = readSingle events
218− in readMap ((bs, next) : pairs) rest
219− readMap _ (e:_) = error $ "Unexpected event in readMap: " ++ show e
220− readMap _ [] = error "Unexpected empty event list in readMap"
221
132
222#if TEST
133#if TEST
223newtype MyString = MyString String
134newtype MyString = MyString String
224 deriving (Eq, Show)
135 deriving (Eq, Show)
225−instance ConvertAttempt MyString Text where
226− convertAttempt = return . convertSuccess
227instance ConvertSuccess MyString Text where
136instance ConvertSuccess MyString Text where
228 convertSuccess (MyString s) = convertSuccess s
137 convertSuccess (MyString s) = convertSuccess s
229−instance ConvertAttempt Text MyString where
230− convertAttempt = return . convertSuccess
231instance ConvertSuccess Text MyString where
138instance ConvertSuccess Text MyString where
232 convertSuccess = MyString . convertSuccess
139 convertSuccess = MyString . convertSuccess
140+instance ConvertSuccess (Object Text Text) (Object MyString MyString) where
141+ convertSuccess = mapKeysValues convertSuccess convertSuccess
142+instance ConvertSuccess (Object MyString MyString) (Object Text Text) where
143+ convertSuccess = mapKeysValues convertSuccess convertSuccess
233
144
234myEquals :: Eq v => Attempt v -> Attempt v -> Bool
145myEquals :: Eq v => Attempt v -> Attempt v -> Bool
235−myEquals (Success v1) (Success v2) = v1 == v2
146+myEquals a1 a2
236−myEquals _ _ = False
147+ | isSuccess a1 && isSuccess a2 = fromSuccess a1 == fromSuccess a2
148+ | otherwise = False
237
149
238propEncodeDecode :: Object MyString MyString -> Bool
150propEncodeDecode :: Object MyString MyString -> Bool
239propEncodeDecode o =
151propEncodeDecode o =
240− fmap h2 (decodeText (encodeText (h1 o) :: B.ByteString))
152+ (decodeTextSuccess $ encodeText' $ convertSuccess o)
241− `myEquals` Success o
153+ `myEquals` return o
242− where
243− h1 = mapKeysValues convertSuccess convertSuccess
244− h2 = mapKeysValues convertSuccess convertSuccess
245
154
246−toSBS :: ConvertSuccess a B.ByteString => a -> B.ByteString
155+toSBS :: ConvertSuccess a ByteString => a -> ByteString
247toSBS = convertSuccess
156toSBS = convertSuccess
248
157
249toLBS :: ConvertSuccess a BL.ByteString => a -> BL.ByteString
158toLBS :: ConvertSuccess a BL.ByteString => a -> BL.ByteString
@@ -258,15 +167,19 @@ caseEmptyStrings = do
258 ]
167 ]
259 let m' = map (toSBS *** toSBS) m
168 let m' = map (toSBS *** toSBS) m
260 let m'' = map (toLBS *** toLBS) m
169 let m'' = map (toLBS *** toLBS) m
261− let test' :: (ToObject x Text Text, FromObject x Text Text, Eq x, Show x)
170+ let test' :: (ConvertSuccess x TextObject,
171+ ConvertSuccess TextObject x,
172+ Eq x,
173+ Show x)
262 => x
174 => x
263 -> Assertion
175 -> Assertion
264− test' x = Just x @=?
176+ test' x = do
265− fa (decodeText (encodeText (toTextObject x) :: String)
177+ let bs = encodeText x
266− >>= fromTextObject)
178+ x' <- decodeTextSuccess bs
179+ x' @?= x
267− test' m
180+ test' $ toTextObject m
268− test' m'
181+ test' $ toTextObject m'
269− test' m''
182+ test' $ toTextObject m''
270
183
271caseLargeObjects :: Assertion
184caseLargeObjects :: Assertion
272caseLargeObjects = do
185caseLargeObjects = do
@@ -274,10 +187,10 @@ caseLargeObjects = do
274 level2 = toTextObject $ replicate 10000 level3
187 level2 = toTextObject $ replicate 10000 level3
275 level1 = toTextObject $ zip (map (: []) ['A'..'Z']) $ repeat level2
188 level1 = toTextObject $ zip (map (: []) ['A'..'Z']) $ repeat level2
276 decoded :: Maybe TextObject
189 decoded :: Maybe TextObject
277− decoded = decodeText $ (encodeText level1 :: Text)
190+ decoded = decodeText $ encodeText level1
278 assertEqual "encode/decode identity" decoded $ Just level1
191 assertEqual "encode/decode identity" decoded $ Just level1
279 putStrLn "encoding the file..."
192 putStrLn "encoding the file..."
280− encodeFile "test.yaml" level1
193+ B.writeFile "test.yaml" $ encodeText' level1
281
194
282testSuite :: Test
195testSuite :: Test
283testSuite = testGroup "Text.Yaml"
196testSuite = testGroup "Text.Yaml"
c/helper.c+17
@@ -90,3 +90,20 @@ unsigned long get_scalar_length(yaml_event_t *e)
90{
90{
91 return e->data.scalar.length;
91 return e->data.scalar.length;
92}
92}
93+
94+unsigned char * get_scalar_tag(yaml_event_t *e)
95+{
96+ unsigned char *s = e->data.scalar.tag;
97+ if (!s) s = "";
98+ return s;
99+}
100+
101+unsigned long get_scalar_tag_len(yaml_event_t *e)
102+{
103+ return strlen(get_scalar_tag(e));
104+}
105+
106+int get_scalar_style(yaml_event_t *e)
107+{
108+ return e->data.scalar.style;
109+}
c/helper.h+4
@@ -26,4 +26,8 @@ int get_event_type(yaml_event_t *e);
26unsigned char * get_scalar_value(yaml_event_t *e);
26unsigned char * get_scalar_value(yaml_event_t *e);
27unsigned long get_scalar_length(yaml_event_t *e);
27unsigned long get_scalar_length(yaml_event_t *e);
28
28
29+unsigned char * get_scalar_tag(yaml_event_t *e);
30+unsigned long get_scalar_tag_len(yaml_event_t *e);
31+int get_scalar_style(yaml_event_t *e);
32+
29#endif /* __HELPER_H__ */
33#endif /* __HELPER_H__ */
Test.hs → runtests.hsrenamed

The content is the same.

yaml.cabal+3−2
@@ -35,6 +35,7 @@ library
35 convertible-text >= 0.0.0 && < 0.1,
35 convertible-text >= 0.0.0 && < 0.1,
36 attempt >= 0.2.0 && < 0.3
36 attempt >= 0.2.0 && < 0.3
37 exposed-modules: Text.Yaml
37 exposed-modules: Text.Yaml
38+ Data.Object.Yaml
38 other-modules: Text.Libyaml
39 other-modules: Text.Libyaml
39 ghc-options: -Wall
40 ghc-options: -Wall
40 c-sources: c/helper.c,
41 c-sources: c/helper.c,
@@ -48,7 +49,7 @@ library
48 c/writer.c
49 c/writer.c
49 include-dirs: c
50 include-dirs: c
50
51
51−executable yamltest
52+executable runtests
52 if flag(buildtests)
53 if flag(buildtests)
53 Buildable: True
54 Buildable: True
54 cpp-options: -DTEST
55 cpp-options: -DTEST
@@ -70,4 +71,4 @@ executable yamltest
70 c/scanner.c,
71 c/scanner.c,
71 c/writer.c
72 c/writer.c
72 include-dirs: c
73 include-dirs: c
73− main-is: Test.hs
74+ main-is: runtests.hs