module Data.Object.Yaml
(
YamlScalar (..)
, YamlObject
, IsYamlScalar (..)
, encode
, encodeFile
, decode
, decodeFile
#if TEST
, testSuite
#endif
) where
import qualified Text.Libyaml as Y
import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
import Data.Object
import Data.ByteString (ByteString)
import System.IO.Unsafe (unsafePerformIO)
import Control.Exception (Exception, SomeException (..))
import Data.Typeable (Typeable)
import Control.Failure
import Control.Applicative
import qualified Data.Text
import qualified Data.Text.Lazy
import "transformers" Control.Monad.Trans
import Control.Monad
#if TEST
import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test, path)
import qualified Data.ByteString.Char8 as B8
#endif
data YamlScalar = YamlScalar
{ value :: ByteString
, tag :: Tag
, style :: Style
}
deriving (Show)
instance Eq YamlScalar where
(YamlScalar v t _) == (YamlScalar v' t' _) = v == v' && t == t'
type YamlObject = Object YamlScalar YamlScalar
class IsYamlScalar a where
fromYamlScalar :: YamlScalar -> a
toYamlScalar :: a -> YamlScalar
instance IsYamlScalar YamlScalar where
fromYamlScalar = id
toYamlScalar = id
instance IsYamlScalar Data.Text.Text where
fromYamlScalar = cs . value
toYamlScalar t = YamlScalar (cs t) NoTag Any
instance IsYamlScalar Data.Text.Lazy.Text where
fromYamlScalar = cs . value
toYamlScalar t = YamlScalar (cs t) NoTag Any
instance IsYamlScalar [Char] where
fromYamlScalar = cs . value
toYamlScalar s = YamlScalar (cs s) NoTag Any
instance IsYamlScalar ByteString where
fromYamlScalar = value
toYamlScalar b = YamlScalar b NoTag Any
encode :: (IsYamlScalar k, IsYamlScalar v) => Object k v -> ByteString
encode = unsafePerformIO . Y.encode . ge
encodeFile :: (IsYamlScalar k, IsYamlScalar v, MonadFailure YamlException m,
With m)
=> FilePath
-> Object k v
-> m ()
encodeFile fp = Y.encodeFile fp . ge
emitEvents :: (MonadIO m, MonadFailure YamlException m)
=> Event -> Event -> YamlEncoder m () -> YamlEncoder m ()
emitEvents start stop body = emitEvent start >> body >> emitEvent stop
ge :: (MonadIO m, MonadFailure YamlException m, IsYamlScalar k,
IsYamlScalar v)
=> Object k v
-> YamlEncoder m ()
ge yo = emitEvents EventStreamStart EventStreamEnd
$ emitEvents EventDocumentStart EventDocumentEnd
$ geO yo
geO :: (MonadIO m, MonadFailure YamlException m, IsYamlScalar k,
IsYamlScalar v)
=> Object k v
-> YamlEncoder m ()
geO (Scalar s) = geS s
geO (Sequence yos) = emitEvents EventSequenceStart EventSequenceEnd
$ mapM_ geO yos
geO (Mapping pairs) = emitEvents EventMappingStart EventMappingEnd
$ mapM_ gePair pairs
gePair :: (MonadIO m, MonadFailure YamlException m, IsYamlScalar k,
IsYamlScalar v)
=> (k, Object k v)
-> YamlEncoder m ()
gePair (ys, yo) = geS ys >> geO yo
geS :: (MonadIO m, IsYamlScalar a, MonadFailure YamlException m)
=> a
-> YamlEncoder m ()
geS = emitEvent . toEventScalar . toYamlScalar
toEventScalar :: YamlScalar -> Event
toEventScalar (YamlScalar v t s) = EventScalar v t s
decode :: (MonadFailure YamlException m, IsYamlScalar k, IsYamlScalar v)
=> ByteString
-> m (Object k v)
decode bs = try $ unsafePerformIO $ unYAttemptIO $ Y.decode bs parse
newtype YAttemptIO v = YAttemptIO
{ unYAttemptIO :: IO (Either YamlException v)
}
instance Monad YAttemptIO where
return = YAttemptIO . return . Right
(YAttemptIO io) >>= f = YAttemptIO $ do
x <- io
case x of
Left e -> return $ Left e
Right y -> unYAttemptIO $ f y
instance Functor YAttemptIO where
fmap = liftM
instance Applicative YAttemptIO where
pure = return
(<*>) = ap
instance Failure YamlException YAttemptIO where
failure = YAttemptIO . return . Left
instance MonadIO YAttemptIO where
liftIO = YAttemptIO . fmap Right
instance With YAttemptIO where
with orig = YAttemptIO . orig . (unYAttemptIO .)
decodeFile :: (MonadFailure YamlException m, IsYamlScalar k, IsYamlScalar v,
With m)
=> FilePath
-> m (Object k v)
decodeFile fp = Y.decodeFile fp parse
requireEvent :: (With m, MonadFailure YamlException m)
=> Event
-> YamlDecoder m ()
requireEvent e = do
e' <- parseEvent
unless (e == e')
$ failure $ YamlOtherException $ SomeException
$ UnexpectedEvent e' $ Just e
data UnexpectedEvent = UnexpectedEvent
{ _received :: Event
, _expected :: Maybe Event
}
deriving (Show, Typeable)
instance Exception UnexpectedEvent
parse :: (With m, MonadFailure YamlException m, IsYamlScalar k,
IsYamlScalar v)
=> YamlDecoder m (Object k v)
parse = do
requireEvent EventStreamStart
requireEvent EventDocumentStart
e <- parseEvent
res <- parseO e
requireEvent EventDocumentEnd
requireEvent EventStreamEnd
requireEvent EventNone
return res
parseO :: (IsYamlScalar k, IsYamlScalar v, With m,
MonadFailure YamlException m)
=> Event
-> YamlDecoder m (Object k v)
parseO (EventScalar v t s) =
return $ Scalar $ fromYamlScalar $ YamlScalar v t s
parseO EventSequenceStart = parseS id
parseO EventMappingStart = parseM id
parseO e = failure $ YamlOtherException $ SomeException
$ UnexpectedEvent e Nothing
parseS :: (IsYamlScalar k, IsYamlScalar v, With m,
MonadFailure YamlException m)
=> ([Object k v] -> [Object k v])
-> YamlDecoder m (Object k v)
parseS front = do
e <- parseEvent
case e of
EventSequenceEnd -> return $ Sequence $ front []
_ -> do
o <- parseO e
parseS $ front . (:) o
parseM :: (IsYamlScalar k, IsYamlScalar v, With m,
MonadFailure YamlException m)
=> ([(k, Object k v)] -> [(k, Object k v)])
-> YamlDecoder m (Object k v)
parseM front = do
e <- parseEvent
case e of
EventMappingEnd -> return $ Mapping $ front []
EventScalar v' t s -> do
let k = fromYamlScalar $ YamlScalar v' t s
v <- parseEvent >>= parseO
parseM $ front . (:) (k, v)
_ -> failure $ YamlOtherException
$ SomeException NonScalarKey
data ParseException = NonScalarKey
deriving (Show, Typeable)
instance Exception ParseException
#if TEST
mkScalar :: String -> YamlScalar
mkScalar s = YamlScalar (cs s) StrTag Folded
sample :: YamlObject
sample = Sequence
[ Scalar $ mkScalar "foo"
, Mapping
[ (mkScalar "bar1", Scalar $ mkScalar "bar2")
]
]
sampleStr :: Object String String
sampleStr = mapKeysValues fromYamlScalar fromYamlScalar sample
testSuite :: Test
testSuite = testGroup "Data.Object.Yaml"
[ testCase "encode/decode" caseEncodeDecode
, testCase "encode/decode file" caseEncodeDecodeFile
, testCase "encode/decode strings" caseEncodeDecodeStrings
, testCase "decode invalid file" caseDecodeInvalid
]
caseEncodeDecode :: Assertion
caseEncodeDecode = do
out <- decode $ encode sample
out @?= sample
caseEncodeDecodeFile :: Assertion
caseEncodeDecodeFile = do
let fp = "tmp.yaml"
encodeFile fp sample
out <- decodeFile fp
out @?= sample
caseEncodeDecodeStrings :: Assertion
caseEncodeDecodeStrings = do
out <- decode $ encode sampleStr
out @?= sampleStr
caseDecodeInvalid :: Assertion
caseDecodeInvalid = do
let invalid = B8.pack "\tthis is 'not' valid :-)"
Nothing @=? (decode invalid :: Maybe YamlObject)
#endif