@@ -3,14 +3,16 @@
33{-# LANGUAGE MultiParamTypeClasses #-}
44{-# LANGUAGE DeriveDataTypeable #-}
55{-# LANGUAGE TypeSynonymInstances #-}
6+{-# LANGUAGE CPP #-}
67module Data.Object.Yaml
7− ( -- * The event stream
8− Event (..)
9− , Style (..)
10− , Tag (..)
8+ ( -- * 'YamlDoc' definition and IO
9+ YamlDoc (..)
10+ , readYamlDoc
11+ , writeYamlDoc
1112 -- * 'YamlObject' definition
12− , YamlDoc (..)
1313 , YamlScalar (..)
14+ , Tag (..)
15+ , Style (..)
1416 , YamlObject
1517 -- * Performing conversions
1618 , eventsToYamlObject
@@ -18,80 +20,53 @@ module Data.Object.Yaml
1820 , YamlException (..)
1921 -- * Re-export
2022 , module Data.Object.Base
23+#if TEST
24+ , testSuite
25+#endif
2126 ) where
2227
2328import Data.ByteString (ByteString)
29+import qualified Data.ByteString as B
2430import Data.Object.Base
2531import Data.Object.Text
26−import Data.Object.Scalar
2732import Data.Convertible.Text
2833import Data.Attempt
2934
30−import Data.Typeable (Typeable)
31−import Control.Exception (Exception)
32−
33−data Event =
34− EventNone
35− | EventStreamStart
36− | EventStreamEnd
37− | EventDocumentStart
38− | EventDocumentEnd
39− | EventAlias
40− | EventScalar ByteString Tag Style
41− | EventSequenceStart
42− | EventSequenceEnd
43− | EventMappingStart
44− | EventMappingEnd
45− deriving (Show, Eq)
35+import Data.Object.Yaml.Internal
36+import Data.Object.Yaml.Lib
37+import Control.Monad ((<=<), join)
38+import System.IO.Unsafe
39+
40+#if TEST
41+import Data.Object
42+import Test.Framework (testGroup, Test)
43+import Test.Framework.Providers.HUnit
44+import Test.Framework.Providers.QuickCheck (testProperty)
45+import Test.HUnit hiding (Test, path)
46+import Test.QuickCheck
4647
47−data Style = Any
48− | Plain
49− | SingleQuoted
50− | DoubleQuoted
51− | Literal
52− | Folded
53− deriving (Show, Eq, Enum, Bounded, Ord)
54−
55−data Tag = StrTag
56− | FloatTag
57− | NullTag
58− | BoolTag
59− | SetTag
60− | IntTag
61− | SeqTag
62− | MapTag
63− | UriTag String
64− | NoTag
65− deriving Eq
66−instance Show Tag where
67− show StrTag = "tag:yaml.org,2002:str"
68− show FloatTag = "tag:yaml.org,2002:float"
69− show NullTag = "tag:yaml.org,2002:null"
70− show BoolTag = "tag:yaml.org,2002:bool"
71− show SetTag = "tag:yaml.org,2002:set"
72− show IntTag = "tag:yaml.org,2002:int"
73− show SeqTag = "tag:yaml.org,2002:seq"
74− show MapTag = "tag:yaml.org,2002:map"
75− show (UriTag s) = s
76− show NoTag = ""
77−instance ConvertSuccess Tag [Char] where
78− convertSuccess = show
79−instance ConvertSuccess ByteString Tag where
80− convertSuccess = (convertSuccess :: String -> Tag)
81− . convertSuccess
82−instance ConvertSuccess [Char] Tag where
83− convertSuccess "tag:yaml.org,2002:str" = StrTag
84− convertSuccess "tag:yaml.org,2002:float" = FloatTag
85− convertSuccess "tag:yaml.org,2002:null" = NullTag
86− convertSuccess "tag:yaml.org,2002:bool" = BoolTag
87− convertSuccess "tag:yaml.org,2002:set" = SetTag
88− convertSuccess "tag:yaml.org,2002:int" = IntTag
89− convertSuccess "tag:yaml.org,2002:seq" = SeqTag
90− convertSuccess "tag:yaml.org,2002:map" = MapTag
91− convertSuccess "" = NoTag
92− convertSuccess s = UriTag s
48+import Control.Monad (replicateM)
49+import qualified Data.Text.Lazy as LT
50+import qualified Data.ByteString.Lazy as BL
51+import qualified Data.ByteString as B
52+import Data.Attempt
53+import Control.Arrow ((***))
54+#endif
9355
9456newtype YamlDoc = YamlDoc { unYamlDoc :: ByteString }
57+instance ConvertSuccess [Event] YamlDoc where
58+ -- Note: the join here will swallow up 'YamlException's.
59+ -- However, these should never occur, as that would imply an error
60+ -- in the C library or bindings.
61+ convertSuccess = YamlDoc . unsafePerformIO . join . encode
62+instance ConvertAttempt YamlDoc [Event] where
63+ convertAttempt = unsafePerformIO . decode . unYamlDoc
64+
65+readYamlDoc :: FilePath -> IO YamlDoc
66+readYamlDoc = fmap YamlDoc . B.readFile
67+
68+writeYamlDoc :: FilePath -> YamlDoc -> IO ()
69+writeYamlDoc fp = B.writeFile fp . unYamlDoc
9570
9671data YamlScalar = YamlScalar
9772 { value :: ByteString
@@ -102,9 +77,9 @@ data YamlScalar = YamlScalar
10277instance ConvertSuccess YamlScalar Event where
10378 convertSuccess (YamlScalar v t s) = EventScalar v (convertSuccess t) s
10479
105−instance ConvertSuccess YamlScalar [Char] where
80+instance ConvertSuccess YamlScalar String where
10681 convertSuccess = convertSuccess . value
107−instance ConvertSuccess [Char] YamlScalar where
82+instance ConvertSuccess String YamlScalar where
10883 convertSuccess t = YamlScalar (convertSuccess t) NoTag Any
10984
11085instance ConvertSuccess YamlScalar Text where
@@ -112,31 +87,16 @@ instance ConvertSuccess YamlScalar Text where
11287instance ConvertSuccess Text YamlScalar where
11388 convertSuccess t = YamlScalar (convertSuccess t) NoTag Any
11489
115−-- FIXME the following are incredibly stupid conversions which ignore tag
116−-- and style information.
90+-- FIXME add Scalar instances
91+{-
11792instance ConvertSuccess YamlScalar Scalar where
11893 convertSuccess = Text . convertSuccess
11994instance ConvertSuccess Scalar YamlScalar where
12095 convertSuccess s = convertSuccess (convertSuccess s :: Text)
96+-}
12197
12298type YamlObject = Object YamlScalar YamlScalar
12399
124−data YamlException =
125− YamlParserException
126− { parserProblem :: String
127− , parserContext :: String
128− , parserOffset :: Int
129− }
130− | YamlEmitterException { emitterProblem :: String }
131− | YamlOutOfMemory
132− | YamlInvalidEventStreamBeginning [Event]
133− | YamlInvalidEventStreamEnd [Event]
134− | YamlPrematureEventStreamEnd
135− | YamlNonScalarKey
136− | YamlInvalidStartingEvent Event
137− deriving (Show, Typeable)
138−instance Exception YamlException
139−
140100-- Emit a YamlObject to an event stream
141101instance ConvertSuccess YamlObject [Event] where
142102 convertSuccess o = EventStreamStart
@@ -152,8 +112,15 @@ instance ConvertSuccess YamlObject [Event] where
152112 : foldr ($) (EventMappingEnd : rest) (map helperPairs pairs)
153113 helperPairs :: (YamlScalar, YamlObject) -> [Event] -> [Event]
154114 helperPairs (k, v) rest = convertSuccess k : helper v rest
115+instance ConvertSuccess YamlObject YamlDoc where
116+ convertSuccess = cs . (cs :: YamlObject -> [Event])
117+instance ConvertAttempt YamlDoc YamlObject where
118+ convertAttempt = ca <=< (ca :: YamlDoc -> Attempt [Event])
155119
156−-- Parse a YamlObject from an event stream
120+instance ConvertAttempt [Event] YamlObject where
121+ convertAttempt = eventsToYamlObject
122+
123+-- | Parse a YamlObject from an event stream
157124eventsToYamlObject :: MonadFailure YamlException m
158125 => [Event]
159126 -> m YamlObject
@@ -204,12 +171,123 @@ eventsToYamlObject (EventStreamStart:EventDocumentStart:events) = h1 events
204171 readMap (f . ((:) (key', val))) rest'
205172eventsToYamlObject e = failure $ YamlInvalidEventStreamBeginning e
206173
207−instance ConvertSuccess (Object YamlScalar YamlScalar) (Object Text Text) where
208− convertSuccess = mapKeysValues convertSuccess convertSuccess
209−instance ConvertSuccess (Object Text Text) (Object YamlScalar YamlScalar) where
210− convertSuccess = mapKeysValues convertSuccess convertSuccess
174+instance ConvertSuccess YamlObject TextObject where
175+ convertSuccess = mapKeysValues cs cs
176+instance ConvertSuccess TextObject YamlObject where
177+ convertSuccess = mapKeysValues cs cs
178+instance ConvertSuccess TextObject YamlDoc where
179+ convertSuccess = cs . (cs :: TextObject -> YamlObject)
180+instance ConvertAttempt YamlDoc TextObject where
181+ convertAttempt = fmap cs . (ca :: YamlDoc -> Attempt YamlObject)
211182
183+{- FIXME
212184instance ConvertSuccess (Object YamlScalar YamlScalar) (Object String Scalar) where
213185 convertSuccess = mapKeysValues convertSuccess convertSuccess
214186instance ConvertSuccess (Object String Scalar) (Object YamlScalar YamlScalar) where
215187 convertSuccess = mapKeysValues convertSuccess convertSuccess
188+-}
189+
190+#if TEST
191+newtype MyString = MyString String
192+ deriving (Eq, Show)
193+instance ConvertSuccess MyString Text where
194+ convertSuccess (MyString s) = convertSuccess s
195+instance ConvertSuccess Text MyString where
196+ convertSuccess = MyString . convertSuccess
197+instance ConvertSuccess (Object Text Text) (Object MyString MyString) where
198+ convertSuccess = mapKeysValues convertSuccess convertSuccess
199+instance ConvertSuccess (Object MyString MyString) (Object Text Text) where
200+ convertSuccess = mapKeysValues convertSuccess convertSuccess
201+
202+myEquals :: Eq v => Attempt v -> Attempt v -> Bool
203+myEquals a1 a2
204+ | isSuccess a1 && isSuccess a2 = fromSuccess a1 == fromSuccess a2
205+ | otherwise = False
206+
207+propEncodeDecode :: Object MyString MyString -> Bool
208+propEncodeDecode o =
209+ let to :: TextObject
210+ to = cs o
211+ yd :: YamlDoc
212+ yd = cs to
213+ to' = ca yd
214+ in return to `myEquals` to'
215+
216+toSBS :: ConvertSuccess a ByteString => a -> ByteString
217+toSBS = convertSuccess
218+
219+toLBS :: ConvertSuccess a BL.ByteString => a -> BL.ByteString
220+toLBS = convertSuccess
221+
222+caseEmptyStrings :: Assertion
223+caseEmptyStrings = do
224+ let m =
225+ [ ("foo", "bar")
226+ , ("baz", "")
227+ , ("bin", "")
228+ ]
229+ let m' = map (toSBS *** toSBS) m
230+ let m'' = map (toLBS *** toLBS) m
231+ let test' :: (ConvertSuccess x TextObject,
232+ ConvertSuccess TextObject x,
233+ Eq x,
234+ Show x)
235+ => x
236+ -> Assertion
237+ test' x = do
238+ let to :: TextObject
239+ to = cs x
240+ yd :: YamlDoc
241+ yd = cs to
242+ to' :: Attempt TextObject
243+ to' = ca yd
244+ to'' <- fa to'
245+ to'' @?= to
246+ test' $ toTextObject m
247+ test' $ toTextObject m'
248+ test' $ toTextObject m''
249+
250+{-
251+-- FIXME remove the following
252+instance ToObject [(String, String)] Text Text where
253+ toObject = Mapping . map (cs *** toObject)
254+instance ToObject [(ByteString, ByteString)] Text Text where
255+ toObject = Mapping . map (cs *** toObject)
256+instance ToObject [(BL.ByteString, BL.ByteString)] Text Text where
257+ toObject = Mapping . map (cs *** toObject)
258+instance ToObject [(String, TextObject)] Text Text where
259+ toObject = Mapping . map (cs *** id)
260+-}
261+
262+caseLargeObjects :: Assertion
263+caseLargeObjects = do
264+ let level3 = toTextObject (convertSuccess "X" :: Text)
265+ level2 = toTextObject $ replicate 10000 level3
266+ level1 = toTextObject $ zip (map (: []) ['A'..'Z']) $ repeat level2
267+ decoded :: Maybe TextObject
268+ decoded = fa $ ca $ (cs level1 :: YamlDoc)
269+ assertEqual "encode/decode identity" decoded $ Just level1
270+ putStrLn "encoding the file..."
271+ writeYamlDoc "test.yaml" $ cs level1
272+
273+testSuite :: Test
274+testSuite = testGroup "Text.Yaml"
275+ [ testProperty "propEncodeDecode" propEncodeDecode
276+ , testCase "empty strings" caseEmptyStrings
277+ , testCase "encode large objects" caseLargeObjects
278+ ]
279+
280+instance Arbitrary (Object MyString MyString) where
281+ coarbitrary = undefined
282+ arbitrary = oneof [arbS, arbL, arbM] where
283+ arbS = Scalar `fmap` (arbitrary :: Gen MyString)
284+ arbL = Sequence `fmap` vector 1
285+ arbM = Mapping `fmap` vector 1
286+
287+instance Arbitrary MyString where
288+ coarbitrary = undefined
289+ arbitrary = do
290+ size <- arbitrary
291+ s <- replicateM (size `mod` 5) $ elements ['A'..'Z']
292+ return $! MyString s
293+#endif