module Data.Object.Yaml
(
YamlDoc (..)
, readYamlDoc
, writeYamlDoc
, YamlScalar (..)
, Tag (..)
, Style (..)
, YamlObject
, eventsToYamlObject
, YamlException (..)
, module Data.Object.Base
#if TEST
, testSuite
#endif
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Object.Base
import Data.Object.Text
import Data.Object.String
import Data.Attempt
import Data.Object.Yaml.Internal
import Data.Object.Yaml.Lib
import Control.Monad ((<=<), join)
import System.IO.Unsafe
#if TEST
import Data.Object
import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck (testProperty)
import Test.HUnit hiding (Test, path)
import Test.QuickCheck
import Control.Monad (replicateM)
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as B
import Data.Attempt
import Control.Arrow ((***))
#endif
newtype YamlDoc = YamlDoc { unYamlDoc :: ByteString }
instance ConvertSuccess [Event] YamlDoc where
convertSuccess = YamlDoc . unsafePerformIO . join . encode
instance ConvertAttempt YamlDoc [Event] where
convertAttempt = unsafePerformIO . decode . unYamlDoc
readYamlDoc :: FilePath -> IO YamlDoc
readYamlDoc = fmap YamlDoc . B.readFile
writeYamlDoc :: FilePath -> YamlDoc -> IO ()
writeYamlDoc fp = B.writeFile fp . unYamlDoc
data YamlScalar = YamlScalar
{ value :: ByteString
, tag :: Tag
, style :: Style
}
deriving (Show, Eq)
instance ConvertSuccess YamlScalar Event where
convertSuccess (YamlScalar v t s) = EventScalar v (convertSuccess t) s
instance ConvertSuccess YamlScalar String where
convertSuccess = convertSuccess . value
instance ConvertSuccess String YamlScalar where
convertSuccess t = YamlScalar (convertSuccess t) NoTag Any
instance ConvertSuccess YamlScalar Text where
convertSuccess = convertSuccess . value
instance ConvertSuccess Text YamlScalar where
convertSuccess t = YamlScalar (convertSuccess t) NoTag Any
instance ConvertSuccess YamlScalar ByteString where
convertSuccess = value
instance ConvertSuccess ByteString YamlScalar where
convertSuccess t = YamlScalar t NoTag Any
$(deriveAttempts
[ (''String, ''YamlScalar)
, (''YamlScalar, ''String)
, (''ByteString, ''YamlScalar)
, (''YamlScalar, ''ByteString)
, (''Text, ''YamlScalar)
, (''YamlScalar, ''Text)
])
type YamlObject = Object YamlScalar YamlScalar
$(deriveSuccessConvs ''YamlScalar ''YamlScalar
[''String, ''Text]
[''String, ''Text])
$(deriveSuccessConvs ''String ''String [''YamlScalar] [''YamlScalar])
$(deriveSuccessConvs ''Text ''Text [''YamlScalar] [''YamlScalar])
instance ConvertSuccess YamlObject [Event] where
convertSuccess o = EventStreamStart
: EventDocumentStart
: helper o [EventDocumentEnd, EventStreamEnd] where
helper :: YamlObject -> [Event] -> [Event]
helper (Scalar y) rest = convertSuccess y : rest
helper (Sequence ys) rest =
EventSequenceStart
: foldr ($) (EventSequenceEnd : rest) (map helper ys)
helper (Mapping pairs) rest =
EventMappingStart
: foldr ($) (EventMappingEnd : rest) (map helperPairs pairs)
helperPairs :: (YamlScalar, YamlObject) -> [Event] -> [Event]
helperPairs (k, v) rest = convertSuccess k : helper v rest
instance ConvertSuccess YamlObject YamlDoc where
convertSuccess = cs . (cs :: YamlObject -> [Event])
instance ConvertAttempt YamlDoc YamlObject where
convertAttempt = ca <=< (ca :: YamlDoc -> Attempt [Event])
instance ConvertAttempt [Event] YamlObject where
convertAttempt = eventsToYamlObject
eventsToYamlObject :: MonadFailure YamlException m
=> [Event]
-> m YamlObject
eventsToYamlObject (EventStreamStart:EventDocumentStart:events) = h1 events
where
h1 :: MonadFailure YamlException m => [Event] -> m YamlObject
h1 es = do
(yo, es') <- h2 es
case es' of
[EventDocumentEnd, EventStreamEnd] -> return yo
_ -> failure $ YamlInvalidEventStreamEnd es'
h2 :: MonadFailure YamlException m
=> [Event]
-> m (YamlObject, [Event])
h2 [] = failure YamlPrematureEventStreamEnd
h2 (EventScalar v t s:rest) =
return (Scalar $ YamlScalar v (convertSuccess t) s, rest)
h2 (EventSequenceStart:es) = do
(yos, rest) <- readSeq id es
return (Sequence yos, rest)
h2 (EventMappingStart:es) = do
(ypairs, rest) <- readMap id es
return (Mapping ypairs, rest)
h2 (e:_) = failure $ YamlInvalidStartingEvent e
readSeq :: MonadFailure YamlException m
=> ([YamlObject] -> [YamlObject])
-> [Event]
-> m ([YamlObject], [Event])
readSeq _ [] = failure YamlPrematureEventStreamEnd
readSeq f (EventSequenceEnd:rest) = return (f [], rest)
readSeq f es = do
(next, rest) <- h2 es
readSeq (f . ((:) next)) rest
readMap :: MonadFailure YamlException m
=> ([(YamlScalar, YamlObject)] -> [(YamlScalar, YamlObject)])
-> [Event]
-> m ([(YamlScalar, YamlObject)], [Event])
readMap _ [] = failure YamlPrematureEventStreamEnd
readMap f (EventMappingEnd:rest) = return (f [], rest)
readMap f es = do
(key, rest) <- h2 es
key' <- case key of
Scalar y -> return y
_ -> failure YamlNonScalarKey
(val, rest') <- h2 rest
readMap (f . ((:) (key', val))) rest'
eventsToYamlObject e = failure $ YamlInvalidEventStreamBeginning e
instance ConvertSuccess TextObject YamlDoc where
convertSuccess = cs . (cs :: TextObject -> YamlObject)
instance ConvertAttempt YamlDoc TextObject where
convertAttempt = fmap cs . (ca :: YamlDoc -> Attempt YamlObject)
instance ConvertSuccess StringObject YamlDoc where
convertSuccess = cs . (cs :: StringObject -> YamlObject)
instance ConvertAttempt YamlDoc StringObject where
convertAttempt = fmap cs . (ca :: YamlDoc -> Attempt YamlObject)
#if TEST
newtype MyString = MyString String
deriving (Eq, Show)
instance ConvertSuccess MyString Text where
convertSuccess (MyString s) = convertSuccess s
instance ConvertSuccess Text MyString where
convertSuccess = MyString . convertSuccess
instance ConvertSuccess (Object Text Text) (Object MyString MyString) where
convertSuccess = mapKeysValues convertSuccess convertSuccess
instance ConvertSuccess (Object MyString MyString) (Object Text Text) where
convertSuccess = mapKeysValues convertSuccess convertSuccess
myEquals :: Eq v => Attempt v -> Attempt v -> Bool
myEquals a1 a2
| isSuccess a1 && isSuccess a2 = fromSuccess a1 == fromSuccess a2
| otherwise = False
propEncodeDecode :: Object MyString MyString -> Bool
propEncodeDecode o =
let to :: TextObject
to = cs o
yd :: YamlDoc
yd = cs to
to' = ca yd
in return to `myEquals` to'
toSBS :: ConvertSuccess a ByteString => a -> ByteString
toSBS = convertSuccess
toLBS :: ConvertSuccess a BL.ByteString => a -> BL.ByteString
toLBS = convertSuccess
caseEmptyStrings :: Assertion
caseEmptyStrings = do
let m =
[ ("foo", "bar")
, ("baz", "")
, ("bin", "")
]
let m' = map (toSBS *** toSBS) m
let m'' = map (toLBS *** toLBS) m
let test' :: (ConvertSuccess x TextObject,
ConvertSuccess TextObject x,
Eq x,
Show x)
=> x
-> Assertion
test' x = do
let to :: TextObject
to = cs x
yd :: YamlDoc
yd = cs to
to' :: Attempt TextObject
to' = ca yd
to'' <- fa to'
to'' @?= to
test' $ toTextObject m
test' $ toTextObject m'
test' $ toTextObject m''
caseLargeObjects :: Assertion
caseLargeObjects = do
let level3 = toTextObject (convertSuccess "X" :: Text)
level2 = toTextObject $ replicate 10000 level3
level1 = toTextObject $ zip (map (: []) ['A'..'Z']) $ repeat level2
decoded :: Maybe TextObject
decoded = fa $ ca $ (cs level1 :: YamlDoc)
assertEqual "encode/decode identity" decoded $ Just level1
putStrLn "encoding the file..."
writeYamlDoc "test.yaml" $ cs level1
testSuite :: Test
testSuite = testGroup "Text.Yaml"
[ testProperty "propEncodeDecode" propEncodeDecode
, testCase "empty strings" caseEmptyStrings
, testCase "encode large objects" caseLargeObjects
]
instance Arbitrary (Object MyString MyString) where
coarbitrary = undefined
arbitrary = oneof [arbS, arbL, arbM] where
arbS = Scalar `fmap` (arbitrary :: Gen MyString)
arbL = Sequence `fmap` vector 1
arbM = Mapping `fmap` vector 1
instance Arbitrary MyString where
coarbitrary = undefined
arbitrary = do
size <- arbitrary
s <- replicateM (size `mod` 5) $ elements ['A'..'Z']
return $! MyString s
#endif