@@ -1,319 +0,0 @@
1−{-# LANGUAGE FlexibleInstances #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE DeriveDataTypeable #-}
5−{-# LANGUAGE TypeSynonymInstances #-}
6−{-# LANGUAGE CPP #-}
7−{-# LANGUAGE TemplateHaskell #-}
8−module Data.Object.Yaml
9− ( -- * 'YamlDoc' definition and IO
10− YamlDoc (..)
11− , readYamlDoc
12− , writeYamlDoc
13− -- * Reading directly from files
14− , readYamlObject
15− -- * 'YamlObject' definition
16− , YamlScalar (..)
17− , Tag (..)
18− , Style (..)
19− , YamlObject
20− -- * Performing conversions
21− , eventsToYamlObject
22− -- * Exceptions
23− , YamlException (..)
24− -- * Re-export
25− , module Data.Object.Base
26−#if TEST
27− , testSuite
28−#endif
29− ) where
30−
31−import Data.ByteString (ByteString)
32−import qualified Data.ByteString as B
33−import Data.Object.Base
34−import Data.Object.Text
35−import Data.Object.String
36−import Data.Attempt
37−
38−import Data.Object.Yaml.Internal
39−import Data.Object.Yaml.Lib
40−import Control.Monad ((<=<), join)
41−import System.IO.Unsafe
42−
43−#if TEST
44−import Test.Framework (testGroup, Test)
45−import Test.Framework.Providers.HUnit
46−import Test.Framework.Providers.QuickCheck (testProperty)
47−import Test.HUnit hiding (Test, path)
48−import Test.QuickCheck
49−
50−import Control.Monad (replicateM)
51−import qualified Data.ByteString.Lazy as BL
52−import Control.Arrow ((***))
53−#endif
54−
55−newtype YamlDoc = YamlDoc { unYamlDoc :: ByteString }
56−instance ConvertSuccess [Event] YamlDoc where
57− -- Note: the join here will swallow up 'YamlException's.
58− -- However, these should never occur, as that would imply an error
59− -- in the C library or bindings.
60− convertSuccess = YamlDoc . unsafePerformIO . join . encode
61−instance ConvertAttempt YamlDoc [Event] where
62− convertAttempt = unsafePerformIO . decode . unYamlDoc
63−
64−readYamlDoc :: FilePath -> IO YamlDoc
65−readYamlDoc = fmap YamlDoc . B.readFile
66−
67−writeYamlDoc :: FilePath -> YamlDoc -> IO ()
68−writeYamlDoc fp = B.writeFile fp . unYamlDoc
69−
70−readYamlObject :: FilePath -> IO (Object YamlScalar YamlScalar)
71−readYamlObject fp = do
72− es <- join $ decodeFile fp
73− convertAttemptWrap es
74−
75−data YamlScalar = YamlScalar
76− { value :: ByteString
77− , tag :: Tag
78− , style :: Style
79− }
80− deriving (Show, Eq)
81−instance ConvertSuccess YamlScalar Event where
82− convertSuccess (YamlScalar v t s) = EventScalar v (convertSuccess t) s
83−
84−instance ConvertSuccess YamlScalar String where
85− convertSuccess = convertSuccess . value
86−instance ConvertSuccess String YamlScalar where
87− convertSuccess t = YamlScalar (convertSuccess t) NoTag Any
88−
89−instance ConvertSuccess YamlScalar Text where
90− convertSuccess = convertSuccess . value
91−instance ConvertSuccess Text YamlScalar where
92− convertSuccess t = YamlScalar (convertSuccess t) NoTag Any
93−
94−instance ConvertSuccess YamlScalar ByteString where
95− convertSuccess = value
96−instance ConvertSuccess ByteString YamlScalar where
97− convertSuccess t = YamlScalar t NoTag Any
98−
99−$(deriveAttempts
100− [ (''String, ''YamlScalar)
101− , (''YamlScalar, ''String)
102− , (''ByteString, ''YamlScalar)
103− , (''YamlScalar, ''ByteString)
104− , (''Text, ''YamlScalar)
105− , (''YamlScalar, ''Text)
106− ])
107−
108−-- FIXME add Scalar instances
109−{-
110−instance ConvertSuccess YamlScalar Scalar where
111− convertSuccess = Text . convertSuccess
112−instance ConvertSuccess Scalar YamlScalar where
113− convertSuccess s = convertSuccess (convertSuccess s :: Text)
114−-}
115−
116−type YamlObject = Object YamlScalar YamlScalar
117−
118−$(deriveSuccessConvs ''YamlScalar ''YamlScalar
119− [''String, ''Text]
120− [''String, ''Text])
121−
122−$(deriveSuccessConvs ''String ''String [''YamlScalar] [''YamlScalar])
123−$(deriveSuccessConvs ''Text ''Text [''YamlScalar] [''YamlScalar])
124−
125−-- Emit a YamlObject to an event stream
126−instance ConvertSuccess YamlObject [Event] where
127− convertSuccess o = EventStreamStart
128− : EventDocumentStart
129− : helper o [EventDocumentEnd, EventStreamEnd] where
130− helper :: YamlObject -> [Event] -> [Event]
131− helper (Scalar y) rest = convertSuccess y : rest
132− helper (Sequence ys) rest =
133− EventSequenceStart
134− : foldr ($) (EventSequenceEnd : rest) (map helper ys)
135− helper (Mapping pairs) rest =
136− EventMappingStart
137− : foldr ($) (EventMappingEnd : rest) (map helperPairs pairs)
138− helperPairs :: (YamlScalar, YamlObject) -> [Event] -> [Event]
139− helperPairs (k, v) rest = convertSuccess k : helper v rest
140−instance ConvertSuccess YamlObject YamlDoc where
141− convertSuccess = cs . (cs :: YamlObject -> [Event])
142−instance ConvertAttempt YamlDoc YamlObject where
143− convertAttempt = ca <=< (ca :: YamlDoc -> Attempt [Event])
144−
145−instance ConvertAttempt [Event] YamlObject where
146− convertAttempt = eventsToYamlObject
147−
148−-- | Parse a YamlObject from an event stream
149−eventsToYamlObject :: MonadFailure YamlException m
150− => [Event]
151− -> m YamlObject
152−eventsToYamlObject (EventStreamStart:EventDocumentStart:events) = h1 events
153− where
154− h1 :: MonadFailure YamlException m => [Event] -> m YamlObject
155− h1 es = do
156− (yo, es') <- h2 es
157− case es' of
158− [EventDocumentEnd, EventStreamEnd] -> return yo
159− _ -> failure $ YamlInvalidEventStreamEnd es'
160− h2 :: MonadFailure YamlException m
161− => [Event]
162− -> m (YamlObject, [Event])
163− h2 [] = failure YamlPrematureEventStreamEnd
164− h2 (EventScalar v t s:rest) =
165− return (Scalar $ YamlScalar v (convertSuccess t) s, rest)
166− h2 (EventSequenceStart:es) = do
167− (yos, rest) <- readSeq id es
168− return (Sequence yos, rest)
169− h2 (EventMappingStart:es) = do
170− (ypairs, rest) <- readMap id es
171− return (Mapping ypairs, rest)
172− h2 (e:_) = failure $ YamlInvalidStartingEvent e
173−
174− readSeq :: MonadFailure YamlException m
175− => ([YamlObject] -> [YamlObject])
176− -> [Event]
177− -> m ([YamlObject], [Event])
178− readSeq _ [] = failure YamlPrematureEventStreamEnd
179− readSeq f (EventSequenceEnd:rest) = return (f [], rest)
180− readSeq f es = do
181− (next, rest) <- h2 es
182− readSeq (f . ((:) next)) rest
183−
184− readMap :: MonadFailure YamlException m
185− => ([(YamlScalar, YamlObject)] -> [(YamlScalar, YamlObject)])
186− -> [Event]
187− -> m ([(YamlScalar, YamlObject)], [Event])
188− readMap _ [] = failure YamlPrematureEventStreamEnd
189− readMap f (EventMappingEnd:rest) = return (f [], rest)
190− readMap f es = do
191− (key, rest) <- h2 es
192− key' <- case key of
193− Scalar y -> return y
194− _ -> failure YamlNonScalarKey
195− (val, rest') <- h2 rest
196− readMap (f . ((:) (key', val))) rest'
197−eventsToYamlObject e = failure $ YamlInvalidEventStreamBeginning e
198−
199−instance ConvertSuccess TextObject YamlDoc where
200− convertSuccess = cs . (cs :: TextObject -> YamlObject)
201−instance ConvertAttempt YamlDoc TextObject where
202− convertAttempt = fmap cs . (ca :: YamlDoc -> Attempt YamlObject)
203−
204−instance ConvertSuccess StringObject YamlDoc where
205− convertSuccess = cs . (cs :: StringObject -> YamlObject)
206−instance ConvertAttempt YamlDoc StringObject where
207− convertAttempt = fmap cs . (ca :: YamlDoc -> Attempt YamlObject)
208−
209−{- FIXME
210−instance ConvertSuccess (Object YamlScalar YamlScalar) (Object String Scalar) where
211− convertSuccess = mapKeysValues convertSuccess convertSuccess
212−instance ConvertSuccess (Object String Scalar) (Object YamlScalar YamlScalar) where
213− convertSuccess = mapKeysValues convertSuccess convertSuccess
214−-}
215−
216−#if TEST
217−newtype MyString = MyString String
218− deriving (Eq, Show)
219−instance ConvertSuccess MyString Text where
220− convertSuccess (MyString s) = convertSuccess s
221−instance ConvertSuccess Text MyString where
222− convertSuccess = MyString . convertSuccess
223−instance ConvertSuccess (Object Text Text) (Object MyString MyString) where
224− convertSuccess = mapKeysValues convertSuccess convertSuccess
225−instance ConvertSuccess (Object MyString MyString) (Object Text Text) where
226− convertSuccess = mapKeysValues convertSuccess convertSuccess
227−
228−myEquals :: Eq v => Attempt v -> Attempt v -> Bool
229−myEquals a1 a2
230− | isSuccess a1 && isSuccess a2 = fromSuccess a1 == fromSuccess a2
231− | otherwise = False
232−
233−propEncodeDecode :: Object MyString MyString -> Bool
234−propEncodeDecode o =
235− let to :: TextObject
236− to = cs o
237− yd :: YamlDoc
238− yd = cs to
239− to' = ca yd
240− in return to `myEquals` to'
241−
242−toSBS :: ConvertSuccess a ByteString => a -> ByteString
243−toSBS = convertSuccess
244−
245−toLBS :: ConvertSuccess a BL.ByteString => a -> BL.ByteString
246−toLBS = convertSuccess
247−
248−caseEmptyStrings :: Assertion
249−caseEmptyStrings = do
250− let m =
251− [ ("foo", "bar")
252− , ("baz", "")
253− , ("bin", "")
254− ]
255− let m' = map (toSBS *** toSBS) m
256− let m'' = map (toLBS *** toLBS) m
257− let test' :: (ConvertSuccess x TextObject,
258− ConvertSuccess TextObject x,
259− Eq x,
260− Show x)
261− => x
262− -> Assertion
263− test' x = do
264− let to :: TextObject
265− to = cs x
266− yd :: YamlDoc
267− yd = cs to
268− to' :: Attempt TextObject
269− to' = ca yd
270− to'' <- fa to'
271− to'' @?= to
272− test' $ toTextObject m
273− test' $ toTextObject m'
274− test' $ toTextObject m''
275−
276−{-
277−-- FIXME remove the following
278−instance ToObject [(String, String)] Text Text where
279− toObject = Mapping . map (cs *** toObject)
280−instance ToObject [(ByteString, ByteString)] Text Text where
281− toObject = Mapping . map (cs *** toObject)
282−instance ToObject [(BL.ByteString, BL.ByteString)] Text Text where
283− toObject = Mapping . map (cs *** toObject)
284−instance ToObject [(String, TextObject)] Text Text where
285− toObject = Mapping . map (cs *** id)
286−-}
287−
288−caseLargeObjects :: Assertion
289−caseLargeObjects = do
290− let level3 = toTextObject (convertSuccess "X" :: Text)
291− level2 = toTextObject $ replicate 10000 level3
292− level1 = toTextObject $ zip (map (: []) ['A'..'Z']) $ repeat level2
293− decoded :: Maybe TextObject
294− decoded = fa $ ca $ (cs level1 :: YamlDoc)
295− assertEqual "encode/decode identity" decoded $ Just level1
296− putStrLn "encoding the file..."
297− writeYamlDoc "test.yaml" $ cs level1
298−
299−testSuite :: Test
300−testSuite = testGroup "Text.Yaml"
301− [ testProperty "propEncodeDecode" propEncodeDecode
302− , testCase "empty strings" caseEmptyStrings
303− , testCase "encode large objects" caseLargeObjects
304− ]
305−
306−instance Arbitrary (Object MyString MyString) where
307− coarbitrary = undefined
308− arbitrary = oneof [arbS, arbL, arbM] where
309− arbS = Scalar `fmap` (arbitrary :: Gen MyString)
310− arbL = Sequence `fmap` vector 1
311− arbM = Mapping `fmap` vector 1
312−
313−instance Arbitrary MyString where
314− coarbitrary = undefined
315− arbitrary = do
316− size <- arbitrary
317− s <- replicateM (size `mod` 5) $ elements ['A'..'Z']
318− return $! MyString s
319−#endif