@@ -2,6 +2,7 @@
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE MultiParamTypeClasses #-}
44{-# LANGUAGE CPP #-}
5+{-# LANGUAGE PackageImports #-}
56---------------------------------------------------------
67--
78-- Module : Text.Yaml
@@ -20,21 +21,18 @@ module Text.Yaml
2021 (
2122 -- * Exceptions
2223 YamlException (..)
23− ,
24+ -- * Converting to/from 'YamlObject's
25+ , encodeYaml'
26+ , decodeYaml'
27+ , encodeYaml
28+ , decodeYaml
29+ , decodeYamlSuccess
2430 -- * Converting to/from 'TextObject's
25− encodeText
26− , encodeToText
31+ , encodeText'
32+ , decodeText'
33+ , encodeText
2734 , decodeText
28− , decodeFromText
29− , decodeFromTextWrap
30− -- * Convert to/from 'ScalarObejct's
31− , encodeScalar
32− , decodeScalar
33− -- * Files
34− , encodeFile
35− , encodeFileToText
36− , decodeFile
37− , decodeFileFromTextWrap
35+ , decodeTextSuccess
3836#if TEST
3937 , testSuite
4038#endif
@@ -42,20 +40,17 @@ module Text.Yaml
4240
4341import Prelude hiding (readList)
4442import Text.Libyaml
45−import qualified Data.ByteString as B
46−import Data.Object
43+import Data.ByteString (ByteString)
4744import Data.Object.Text
48−import Data.Object.Scalar
4945import System.IO.Unsafe
50−import Control.Arrow (first)
51−import Control.Monad (liftM, join)
52−import Control.Monad.Trans
46+import Control.Monad (join)
5347import Data.Convertible.Text
5448import Data.Attempt
5549
56−import Data.Text.Lazy (Text)
50+import Data.Object.Yaml
5751
5852#if TEST
53+import Data.Object
5954import Test.Framework (testGroup, Test)
6055import Test.Framework.Providers.HUnit
6156import Test.Framework.Providers.QuickCheck (testProperty)
@@ -63,187 +58,101 @@ import Test.HUnit hiding (Test, path)
6358import Test.QuickCheck
6459
6560import Control.Monad (replicateM)
66−import Control.Arrow ((***))
6761import qualified Data.Text.Lazy as LT
6862import qualified Data.ByteString.Lazy as BL
63+import qualified Data.ByteString as B
64+import Data.Attempt
65+import Control.Arrow ((***))
6966#endif
7067
7168-- Low level, non-exported functions
7269encode' :: MonadFailure YamlException m
73− => TextObject
74− -> IO (m B.ByteString)
75−encode' o = do
76− let events = objectToEvents o
77− result <- withEmitter $ flip emitEvents events
78− return $ do
79− result' <- result
80− return result'
70+ => YamlObject
71+ -> IO (m ByteString)
72+encode' = withEmitter . flip emitEvents . convertSuccess
8173
8274decode' :: MonadFailure YamlException m
83− => B.ByteString
84− -> IO (m TextObject)
75+ => ByteString
76+ -> IO (m YamlObject)
8577decode' bs = do
86− events <- withParser (convertSuccess bs) parserParse
87− return $ liftM eventsToTextObject events
88−
89−-- Text API
90−-- FIXME: this *should* be in a MonadFailure
91−
92−-- FIXME: I think the To and From below are backwards. Maybe just say convert?
93−encodeText :: ConvertSuccess B.ByteString a
94− => TextObject
95− -> a
96−encodeText = convertSuccess . unsafePerformIO . join . encode'
97−
98−encodeToText :: (ConvertSuccess B.ByteString a, ToObject x Text Text)
99− => x
100− -> a
101−encodeToText = convertSuccess . unsafePerformIO . join . encode' . toTextObject
102−
103−decodeText :: (ConvertSuccess a B.ByteString,
104− MonadFailure YamlException m)
105− => a
106− -> m TextObject
107−decodeText = unsafePerformIO . decode' . convertSuccess
108−
109−decodeFromText :: (ConvertSuccess a B.ByteString,
110− FromObject x Text Text)
111− => a
112− -> Attempt x
113−decodeFromText a = decodeText a >>= fromObject
114−
115−decodeFromTextWrap :: (ConvertSuccess a B.ByteString,
116− FromObject x Text Text,
117− MonadFailure YamlException m,
118− MonadFailure FromObjectException m
119− )
120− => a
121− -> m x
122−decodeFromTextWrap a = decodeText a >>= fromObjectWrap
123−
124−-- Scalar API
125−-- FIXME: this *should* be in a MonadFailure...
126−encodeScalar :: ConvertSuccess B.ByteString a
127− => ScalarObject
128− -> a
129−encodeScalar = convertSuccess . unsafePerformIO . join . encode' . toTextObject
130−
131−decodeScalar :: (ConvertSuccess a B.ByteString,
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)
139− => FilePath
140− -> TextObject
141− -> m ()
142−encodeFile path o = do
143− content <- liftIO $ encode' o
144− content' <- content
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"
78+ events <- withParser bs parserParse
79+ return $ events >>= eventsToYamlObject
80+
81+-- Convert to YamlObject directly
82+encodeYaml' :: YamlObject -> ByteString
83+encodeYaml' = unsafePerformIO . join . encode'
84+
85+decodeYaml' :: MonadFailure YamlException m => ByteString -> m YamlObject
86+decodeYaml' = unsafePerformIO . decode'
87+
88+-- Convert to YamlObject conversions
89+encodeYaml :: ConvertSuccess x YamlObject => x -> ByteString
90+encodeYaml = encodeYaml' . convertSuccess
91+
92+decodeYaml :: ( ConvertAttempt YamlObject x
93+ , Failure ConversionException m
94+ , MonadFailure YamlException m
95+ )
96+ => ByteString
97+ -> m x
98+decodeYaml b = decodeYaml' b >>= convertAttemptWrap
99+
100+decodeYamlSuccess :: ( ConvertSuccess YamlObject x
101+ , MonadFailure YamlException m
102+ )
103+ => ByteString
104+ -> m x
105+decodeYamlSuccess = fmap convertSuccess . decodeYaml'
106+
107+-- TextObjects
108+encodeText' :: TextObject -> ByteString
109+encodeText' = encodeYaml
110+
111+decodeText' :: MonadFailure YamlException m => ByteString -> m TextObject
112+decodeText' = decodeYamlSuccess
113+
114+-- TextObject conversions
115+encodeText :: ConvertSuccess x TextObject => x -> ByteString
116+encodeText = encodeText' . convertSuccess
117+
118+decodeText :: ( MonadFailure YamlException m
119+ , ConvertAttempt TextObject x
120+ , Failure ConversionException m
121+ )
122+ => ByteString
123+ -> m x
124+decodeText bs = decodeText' bs >>= convertAttemptWrap
125+
126+decodeTextSuccess :: ( MonadFailure YamlException m
127+ , ConvertSuccess TextObject x
128+ )
129+ => ByteString
130+ -> m x
131+decodeTextSuccess = fmap convertSuccess . decodeText'
221132
222133#if TEST
223134newtype MyString = MyString String
224135 deriving (Eq, Show)
225−instance ConvertAttempt MyString Text where
226− convertAttempt = return . convertSuccess
227136instance ConvertSuccess MyString Text where
228137 convertSuccess (MyString s) = convertSuccess s
229−instance ConvertAttempt Text MyString where
230− convertAttempt = return . convertSuccess
231138instance ConvertSuccess Text MyString where
232139 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
233144
234145myEquals :: Eq v => Attempt v -> Attempt v -> Bool
235−myEquals (Success v1) (Success v2) = v1 == v2
236−myEquals _ _ = False
146+myEquals a1 a2
147+ | isSuccess a1 && isSuccess a2 = fromSuccess a1 == fromSuccess a2
148+ | otherwise = False
237149
238150propEncodeDecode :: Object MyString MyString -> Bool
239151propEncodeDecode o =
240− fmap h2 (decodeText (encodeText (h1 o) :: B.ByteString))
241− `myEquals` Success o
242− where
243− h1 = mapKeysValues convertSuccess convertSuccess
244− h2 = mapKeysValues convertSuccess convertSuccess
152+ (decodeTextSuccess $ encodeText' $ convertSuccess o)
153+ `myEquals` return o
245154
246−toSBS :: ConvertSuccess a B.ByteString => a -> B.ByteString
155+toSBS :: ConvertSuccess a ByteString => a -> ByteString
247156toSBS = convertSuccess
248157
249158toLBS :: ConvertSuccess a BL.ByteString => a -> BL.ByteString
@@ -258,15 +167,19 @@ caseEmptyStrings = do
258167 ]
259168 let m' = map (toSBS *** toSBS) m
260169 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)
262174 => x
263175 -> Assertion
264− test' x = Just x @=?
265− fa (decodeText (encodeText (toTextObject x) :: String)
266− >>= fromTextObject)
267− test' m
268− test' m'
269− test' m''
176+ test' x = do
177+ let bs = encodeText x
178+ x' <- decodeTextSuccess bs
179+ x' @?= x
180+ test' $ toTextObject m
181+ test' $ toTextObject m'
182+ test' $ toTextObject m''
270183
271184caseLargeObjects :: Assertion
272185caseLargeObjects = do
@@ -274,10 +187,10 @@ caseLargeObjects = do
274187 level2 = toTextObject $ replicate 10000 level3
275188 level1 = toTextObject $ zip (map (: []) ['A'..'Z']) $ repeat level2
276189 decoded :: Maybe TextObject
277− decoded = decodeText $ (encodeText level1 :: Text)
190+ decoded = decodeText $ encodeText level1
278191 assertEqual "encode/decode identity" decoded $ Just level1
279192 putStrLn "encoding the file..."
280− encodeFile "test.yaml" level1
193+ B.writeFile "test.yaml" $ encodeText' level1
281194
282195testSuite :: Test
283196testSuite = testGroup "Text.Yaml"