@@ -1,3 +1,5 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1---------------------------------------------------------
3---------------------------------------------------------
3-- Module : Text.Yaml
5-- Module : Text.Yaml
@@ -18,6 +20,7 @@ module Text.Yaml
18 , encodeFile
20 , encodeFile
20 , decodeFile
22 , decodeFile
23import Prelude hiding (readList)
26import Prelude hiding (readList)
@@ -25,53 +28,62 @@ import Text.Libyaml
25import qualified Data.ByteString as B
28import qualified Data.ByteString as B
26import qualified Data.ByteString.Lazy as BL
29import qualified Data.ByteString.Lazy as BL
27import Data.ByteString.Class
30import Data.ByteString.Class
28−import Data.Object
31+import Data.Object hiding (testSuite)
29import System.IO.Unsafe
32import System.IO.Unsafe
30−import Control.Arrow (first)
33+import Control.Arrow (first, (***))
34+import Control.Monad (replicateM)
36+import Test.Framework (testGroup, Test)
37+import Test.Framework.Providers.HUnit
38+import Test.Framework.Providers.QuickCheck (testProperty)
39+import Test.HUnit hiding (Test, path)
40+import Test.QuickCheck
32−encode :: (StrictByteString bs, ToObject o) => o -> bs
42+encode :: (StrictByteString bs, ToRawObject o) => o -> bs
33encode = unsafePerformIO . encode'
43encode = unsafePerformIO . encode'
35−decode :: (Monad m, StrictByteString bs, FromObject o) => bs -> m o
45+decode :: (MonadFail m, StrictByteString bs, FromRawObject o) => bs -> m o
36decode = unsafePerformIO . decode'
46decode = unsafePerformIO . decode'
38−encodeFile :: ToObject o => FilePath -> o -> IO ()
48+encodeFile :: ToRawObject o => FilePath -> o -> IO ()
39encodeFile path o = encode' o >>= B.writeFile path
49encodeFile path o = encode' o >>= B.writeFile path
41−decodeFile :: (Monad m, FromObject o) => FilePath -> IO (m o)
51+decodeFile :: (MonadFail m, FromRawObject o) => FilePath -> IO (m o)
42decodeFile path = do
52decodeFile path = do
43 c <- B.readFile path
53 c <- B.readFile path
46−encode' :: (StrictByteString bs, ToObject o) => o -> IO bs
56+encode' :: (StrictByteString bs, ToRawObject o) => o -> IO bs
47encode' o =
57encode' o =
48− let events = objectToEvents $ toObject o
58+ let events = objectToEvents $ toRawObject o
49 result = withEmitter $ flip emitEvents $ events
59 result = withEmitter $ flip emitEvents $ events
50 in fromStrictByteString `fmap` result
60 in fromStrictByteString `fmap` result
52−decode' :: (Monad m, StrictByteString bs, FromObject o) => bs -> IO (m o)
62+decode' :: (MonadFail m, StrictByteString bs, FromRawObject o)
53decode' bs = do
65decode' bs = do
54 let bs' = toStrictByteString bs
66 let bs' = toStrictByteString bs
55 events = withParser bs' parserParse
67 events = withParser bs' parserParse
56− (fromObject . eventsToObject) `fmap` events
68+ (fromRawObject . eventsToRawObject) `fmap` events
58−objectToEvents :: Object -> [Event]
70+objectToEvents :: RawObject -> [Event]
59objectToEvents y = concat
71objectToEvents y = concat
60 [ [EventStreamStart, EventDocumentStart]
72 [ [EventStreamStart, EventDocumentStart]
61 , writeSingle y
73 , writeSingle y
62 , [EventDocumentEnd, EventStreamEnd]] where
74 , [EventDocumentEnd, EventStreamEnd]] where
63− writeSingle :: Object -> [Event]
75+ writeSingle :: RawObject -> [Event]
64 writeSingle (Scalar bs) = [EventScalar $ fromLazyByteString bs]
76 writeSingle (Scalar bs) = [EventScalar $ fromLazyByteString bs]
65 writeSingle (Sequence ys) =
77 writeSingle (Sequence ys) =
66 (EventSequenceStart : concatMap writeSingle ys)
78 (EventSequenceStart : concatMap writeSingle ys)
67 ++ [EventSequenceEnd]
79 ++ [EventSequenceEnd]
68 writeSingle (Mapping pairs) =
80 writeSingle (Mapping pairs) =
69 EventMappingStart : concatMap writePair pairs ++ [EventMappingEnd]
81 EventMappingStart : concatMap writePair pairs ++ [EventMappingEnd]
70− writePair :: (BL.ByteString, Object) -> [Event]
82+ writePair :: (BL.ByteString, RawObject) -> [Event]
71 writePair (k, v) = EventScalar (fromLazyByteString k) : writeSingle v
83 writePair (k, v) = EventScalar (fromLazyByteString k) : writeSingle v
73−eventsToObject :: [Event] -> Object
85+eventsToRawObject :: [Event] -> RawObject
74−eventsToObject = fst . readSingle . dropWhile isIgnored where
86+eventsToRawObject = fst . readSingle . dropWhile isIgnored where
75 isIgnored EventAlias = False
87 isIgnored EventAlias = False
76 isIgnored (EventScalar _) = False
88 isIgnored (EventScalar _) = False
77 isIgnored EventSequenceStart = False
89 isIgnored EventSequenceStart = False
@@ -79,19 +91,21 @@ eventsToObject = fst . readSingle . dropWhile isIgnored where
79 isIgnored EventMappingStart = False
91 isIgnored EventMappingStart = False
80 isIgnored EventMappingEnd = False
92 isIgnored EventMappingEnd = False
81 isIgnored _ = True
93 isIgnored _ = True
82− readSingle :: [Event] -> (Object, [Event])
94+ readSingle :: [Event] -> (RawObject, [Event])
83 readSingle [] = error "readSingle: no more events"
95 readSingle [] = error "readSingle: no more events"
84 readSingle (EventScalar bs:rest) = (Scalar $ toLazyByteString bs, rest)
96 readSingle (EventScalar bs:rest) = (Scalar $ toLazyByteString bs, rest)
85 readSingle (EventSequenceStart:rest) = readList [] rest
97 readSingle (EventSequenceStart:rest) = readList [] rest
86 readSingle (EventMappingStart:rest) = readMap [] rest
98 readSingle (EventMappingStart:rest) = readMap [] rest
87 readSingle (x:_) = error $ "readSingle: " ++ show x
99 readSingle (x:_) = error $ "readSingle: " ++ show x
88− readList :: [Object] -> [Event] -> (Object, [Event])
100+ readList :: [RawObject] -> [Event] -> (RawObject, [Event])
89 readList nodes (EventSequenceEnd:rest) =
101 readList nodes (EventSequenceEnd:rest) =
90 (Sequence $ reverse nodes, rest)
102 (Sequence $ reverse nodes, rest)
91 readList nodes events =
103 readList nodes events =
92 let (next, rest) = readSingle events
104 let (next, rest) = readSingle events
93 in readList (next : nodes) rest
105 in readList (next : nodes) rest
94− readMap :: [(B.ByteString, Object)] -> [Event] -> (Object, [Event])
106+ readMap :: [(B.ByteString, RawObject)]
108+ -> (RawObject, [Event])
95 readMap pairs (EventMappingEnd:rest) =
109 readMap pairs (EventMappingEnd:rest) =
96 (Mapping $ map (first toLazyByteString) $ reverse pairs, rest)
110 (Mapping $ map (first toLazyByteString) $ reverse pairs, rest)
97 readMap pairs (EventScalar bs:events) =
111 readMap pairs (EventScalar bs:events) =
@@ -99,3 +113,41 @@ eventsToObject = fst . readSingle . dropWhile isIgnored where
99 in readMap ((fromStrictByteString bs, next) : pairs) rest
113 in readMap ((fromStrictByteString bs, next) : pairs) rest
100 readMap _ (e:_) = error $ "Unexpected event in readMap: " ++ show e
114 readMap _ (e:_) = error $ "Unexpected event in readMap: " ++ show e
101 readMap _ [] = error "Unexpected empty event list in readMap"
115 readMap _ [] = error "Unexpected empty event list in readMap"
117+newtype MyString = MyString String
118+ deriving (Eq, Show, ToRaw, FromRaw, ToRawObject, FromRawObject)
119+propEncodeDecode :: Object MyString MyString -> Bool
120+propEncodeDecode o = decode (encode o :: B.ByteString) == Just o
122+caseEmptyStrings :: Assertion
123+caseEmptyStrings = do
129+ let m' = map (toStrictByteString *** toStrictByteString) m
130+ let m'' = map (toLazyByteString *** toLazyByteString) m
131+ Just m @=? decode (encode m :: String)
132+ Just m' @=? decode (encode m' :: String)
133+ Just m'' @=? decode (encode m'' :: String)
136+testSuite = testGroup "Text.Yaml"
137+ [ testProperty "propEncodeDecode" propEncodeDecode
138+ , testCase "empty strings" caseEmptyStrings
141+instance Arbitrary (Object MyString MyString) where
142+ coarbitrary = undefined
143+ arbitrary = oneof [arbS, arbL, arbM] where
144+ arbS = Scalar `fmap` (arbitrary :: Gen MyString)
145+ arbL = Sequence `fmap` vector 1
146+ arbM = Mapping `fmap` vector 1
148+instance Arbitrary MyString where
149+ coarbitrary = undefined
152+ s <- replicateM (size `mod` 5) $ elements ['A'..'Z']
153+ return $! MyString s