Yaml.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PackageImports #-}
{-|
As a bit of background, this package is built on a few other packages I wrote.
yaml is a low-level wrapper around the C libyaml library, with an enumerator
interface. data-object is a package defining a data type:

@
    data Object k v = Scalar v
                    | Sequence [Object k v]
                    | Mapping [(k, Object k v)]
@

In other words, it can represent JSON data fully, and YAML data almost fully.
In particular, it doesn't handle cyclical aliases, which I hope doesn't really
occur too much in real life.

Another package to deal with is failure: it basically replaces using an Either
for error-handling into a typeclass. It has instances for Maybe, IO and lists
    by default.

The last package is convertible-text, which is a fork of John Goerzen's
convertible package. The difference is it supports both conversions that are
guaranteed to succeed (Int -> String) and ones which may fail (String -> Int),
and also supports various textual datatypes (String, lazy\/strict ByteString,
lazy\/string Text).

/YamlScalar and YamlObject/

We have a @type YamlObject = Object YamlScalar YamlScalar@, where a YamlScalar
is just a ByteString value with a tag and a style. A \"style\" is how the data
was represented in the underlying YAML file: single quoted, double quoted, etc.

Then there is an IsYamlScalar typeclass, which provides fromYamlScalar and
toYamlScalar conversion functions. There are instances for all the
\"text-like\" datatypes: String, ByteString and Text. The built-in instances
all assume a UTF-8 data encoding. And around this we have toYamlObject and
fromYamlObject functions, which do exactly what they sound like.

/Encoding and decoding/

There are two encoding files: encode and encodeFile. You can guess the
different: the former produces a ByteString (strict) and the latter writes to a
file. They both take an Object, whose keys and values must be an instance of
IsYamlScalar. So, for example:

@
    encodeFile "myfile.yaml" $ Mapping
        [ ("Michael", Mapping
            [ ("age", Scalar "26")
            , ("color", Scalar "blue")
            ])
        , ("Eliezer", Mapping
            [ ("age", Scalar "2")
            , ("color", Scalar "green")
            ])
        ]
@

decoding is only slightly more complicated, since the decoding can fail. In
particular, the return type is an IO wrapped around a Failure. For example, you
could use:

@
    maybeObject <- decodeFile "myfile.yaml"
    case maybeObject of
        Nothing -> putStrLn "Error parsing YAML file."
        Just object -> putStrLn "Successfully parsed."
@

If you just want to throw any parse errors as IO exception, you can use join:

@
    import Control.Monad (join)
    object <- join $ decodeFile "myfile.yaml"
@

This takes advantage of the IO instance of Failure.

/Parsing an Object/

In order to pull the data out of an Object, you can use the helper functions
from Data.Object. For example:

@
    import Data.Object
    import Data.Object.Yaml
    import Control.Monad

    main = do
        object <- join $ decodeFile "myfile.yaml"
        people <- fromMapping object
        michael <- lookupMapping "Michael" people
        age <- lookupScalar "age" michael
        putStrLn $ "Michael is " ++ age ++ " years old."
@

lookupScalar and friends implement Maybe, so you can test for optional 
attributes by switching on Nothing/Just a:

@
    name <- lookupScalar "middleName" michael :: Maybe String
@


/And that's it/

There's really not more to know about this library. Enjoy!
-}
module Data.Object.Yaml
    ( -- * Definition of 'YamlObject'
      YamlScalar (..)
    , YamlObject
      -- * Automatic scalar conversions
    , IsYamlScalar (..)
    , toYamlObject
    , fromYamlObject
      -- * Encoding/decoding
    , encode
    , encodeFile
    , decode
    , decodeFile
      -- * Exceptions
    , ParseException (..)
    ) where

import qualified Text.Libyaml as Y
import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
import Data.Object
import Data.ByteString (ByteString)
import qualified Data.Map as Map
import System.IO.Unsafe (unsafePerformIO)
import Control.Failure

import qualified Data.Text
import qualified Data.Text.Lazy
import qualified Data.ByteString
import qualified Data.ByteString.Lazy

import Data.Convertible.Text (cs)
import Data.Data

import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Control.Monad.Trans.State
import Control.Monad
import qualified Data.Enumerator as E
import Data.Enumerator (($$))
import Prelude hiding (catch)
import Control.Exception (throwIO, Exception)
import Data.String (IsString (fromString))

-- | Equality depends on 'value' and 'tag', not 'style'.
data YamlScalar = YamlScalar
    { value :: ByteString
    , tag :: Tag
    , style :: Style
    }
    deriving (Show, Read, Data, Typeable)
instance Eq YamlScalar where
    (YamlScalar v t _) == (YamlScalar v' t' _) = v == v' && t == t'
instance IsString YamlScalar where
    fromString = toYamlScalar

type YamlObject = Object YamlScalar YamlScalar

class (Eq a) => 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 Data.ByteString.ByteString where
    fromYamlScalar = value
    toYamlScalar b = YamlScalar b NoTag Any
instance IsYamlScalar Data.ByteString.Lazy.ByteString where
    fromYamlScalar = cs . value
    toYamlScalar b = YamlScalar (cs b) NoTag Any

-- | Merge assoc-lists by keys.
-- First list overrides second:
--     [(k1, x), (k2, y)] `mergeAssocLists` [(k3, z)] == [(k1, x), (k2, y), (k3, z)]
--     [(k1, x), (k2, y)] `mergeAssocLists` [(k2, z)] == [(k1, x), (k2, y)]
mergeAssocLists :: (Eq k) => [(k, v)] -> [(k, v)] -> [(k, v)]
mergeAssocLists a [] = a
mergeAssocLists [] b = b
mergeAssocLists a ((bk, bv):bs) =
    case lookup bk a of
      Nothing -> (bk, bv) : mergeAssocLists a bs
      Just av -> (bk, av) : mergeAssocLists (filter (\(x, _) -> x /= bk) a) bs

toYamlObject :: IsYamlScalar k
             => IsYamlScalar v
             => Object k v
             -> YamlObject
toYamlObject = mapKeysValues toYamlScalar toYamlScalar

fromYamlObject :: IsYamlScalar k
               => IsYamlScalar v
               => YamlObject
               -> Object k v
fromYamlObject = mapKeysValues fromYamlScalar fromYamlScalar

encode :: (IsYamlScalar k, IsYamlScalar v) => Object k v -> ByteString
encode obj = unsafePerformIO $ do
    x <- E.run $ E.enumList 1 (objToEvents $ toYamlObject obj) $$ Y.encode
    case x of
        Left err -> throwIO err
        Right y -> return y

encodeFile :: (IsYamlScalar k, IsYamlScalar v)
           => FilePath
           -> Object k v
           -> IO ()
encodeFile fp obj = do
    x <- E.run $ E.enumList 1 (objToEvents $ toYamlObject obj)
              $$ Y.encodeFile fp
    case x of
        Left err -> throwIO err
        Right () -> return ()

objToEvents :: YamlObject -> [Y.Event]
objToEvents o = (:) EventStreamStart
              . (:) EventDocumentStart
              $ objToEvents' o
              [ EventDocumentEnd
              , EventStreamEnd
              ]

scalarToEvent :: YamlScalar -> Event
scalarToEvent (YamlScalar v t s) = EventScalar v t s Nothing

objToEvents' :: YamlObject -> [Y.Event] -> [Y.Event]
objToEvents' (Scalar s) rest = scalarToEvent s : rest
objToEvents' (Sequence list) rest =
    EventSequenceStart Nothing
  : foldr ($) (EventSequenceEnd : rest) (map objToEvents' list)
objToEvents' (Mapping pairs) rest =
    EventMappingStart Nothing
  : foldr ($) (EventMappingEnd : rest) (map pairToEvents pairs)

pairToEvents :: (YamlScalar, YamlObject) -> [Y.Event] -> [Y.Event]
pairToEvents (k, v) rest =
    scalarToEvent k
  : objToEvents' v rest

-- Parsing

data ParseException = NonScalarKey
                    | UnknownAlias { _anchorName :: Y.AnchorName }
                    | UnexpectedEvent { _received :: Maybe Event
                                      , _expected :: Maybe Event
                                      }
                    | InvalidYaml (Maybe String)
    deriving (Show, Typeable)
instance Exception ParseException

newtype PErrorT m a = PErrorT { runPErrorT :: m (Either ParseException a) }
instance Monad m => Monad (PErrorT m) where
    return = PErrorT . return . Right
    (PErrorT m) >>= f = PErrorT $ do
        e <- m
        case e of
            Left e' -> return $ Left e'
            Right a -> runPErrorT $ f a
instance MonadTrans PErrorT where
    lift = PErrorT . liftM Right
instance MonadIO m => MonadIO (PErrorT m) where
    liftIO = lift . liftIO

pfailure :: Monad m => ParseException -> PErrorT m a
pfailure = PErrorT . return . Left

type Parser = PErrorT (StateT (Map.Map String YamlObject) IO)

requireEvent :: Event -> E.Iteratee Event Parser ()
requireEvent e = do
    f <- E.head
    if f == Just e
        then return ()
        else lift $ pfailure $ UnexpectedEvent f $ Just e

parse :: E.Iteratee Event Parser YamlObject
parse = do
    requireEvent EventStreamStart
    requireEvent EventDocumentStart
    res <- parseO
    requireEvent EventDocumentEnd
    requireEvent EventStreamEnd
    return res

parseScalar :: ByteString -> Tag -> Style -> Anchor
            -> E.Iteratee Event Parser YamlScalar
parseScalar v t s a = do
    let res = YamlScalar v t s
    case a of
        Nothing -> return res
        Just an -> do
            lift $ lift $ modify (Map.insert an $ Scalar res)
            return res

parseO :: E.Iteratee Event Parser YamlObject
parseO = do
    me <- E.head
    case me of
        Just (EventScalar v t s a) -> Scalar `liftM` parseScalar v t s a
        Just (EventSequenceStart a) -> parseS a id
        Just (EventMappingStart a) -> parseM a id
        Just (EventAlias an) -> do
            m <- lift $ lift get
            case Map.lookup an m of
                Nothing -> lift $ pfailure $ UnknownAlias an
                Just v -> return v
        _ -> lift $ pfailure $ UnexpectedEvent me Nothing

parseS :: Y.Anchor
       -> ([YamlObject] -> [YamlObject])
       -> E.Iteratee Event Parser YamlObject
parseS a front = do
    me <- E.peek
    case me of
        Just EventSequenceEnd -> do
            E.drop 1
            let res = Sequence $ front []
            case a of
                Nothing -> return res
                Just an -> do
                    lift $ lift $ modify $ Map.insert an res
                    return res
        _ -> do
            o <- parseO
            parseS a $ front . (:) o

parseM :: Y.Anchor
       -> ([(YamlScalar, YamlObject)] -> [(YamlScalar, YamlObject)])
       -> E.Iteratee Event Parser YamlObject
parseM a front = do
    me <- E.peek
    case me of
        Just EventMappingEnd -> do
            E.drop 1
            let res = Mapping $ front []
            case a of
                Nothing -> return res
                Just an -> do
                    lift $ lift $ modify $ Map.insert an res
                    return res
        _ -> do
            me' <- E.head
            s <- case me' of
                    Just (EventScalar v t s a') -> parseScalar v t s a'
                    _ -> lift $ pfailure $ UnexpectedEvent me' Nothing
            o <- parseO
            let al  = mergeAssocLists [(s, o)] $ front []
                al' = if fromYamlScalar s == "<<"
                         then case o of
                                  Scalar _    -> al
                                  Mapping l  -> mergeAssocLists al l
                                  Sequence l -> mergeAssocLists al $ foldl merge' [] l
                         else al
            parseM a (`mergeAssocLists` al')
    where merge' :: (Eq k) => [(k, Object k v)] -> Object k v -> [(k, Object k v)]
          merge' al (Mapping om) = mergeAssocLists al om
          merge' al _            = al

decode :: (Failure ParseException m, IsYamlScalar k, IsYamlScalar v)
       => ByteString
       -> m (Object k v)
decode bs = unsafePerformIO $ do
    x <- flip evalStateT Map.empty $ runPErrorT $ E.run $ Y.decode bs $$ parse
    case x of
        Left err -> return $ failure err
        Right (Left err) -> return $ failure $ InvalidYaml $ Just $ show err
        Right (Right y) -> return $ return $ fromYamlObject y

decodeFile :: (Failure ParseException m, IsYamlScalar k, IsYamlScalar v)
           => FilePath
           -> IO (m (Object k v))
decodeFile fp = do
    x <- flip evalStateT Map.empty $ runPErrorT $ E.run $ Y.decodeFile fp $$ parse
    case x of
        Left err -> return $ failure err
        Right (Left err) -> return $ failure $ InvalidYaml $ Just $ show err
        Right (Right y) -> return $ return $ fromYamlObject y