{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PackageImports #-}
module Data.Object.Yaml
    ( -- * Definition of 'YamlObject'
      YamlScalar (..)
    , YamlObject
      -- * Automatic scalar conversions
    , IsYamlScalar (..)
      -- * Encoding/decoding
    , 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)
-- debugging purposes import Debug.Trace
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.Framework.Providers.QuickCheck (testProperty)
import Test.HUnit hiding (Test, path)
--import Test.QuickCheck
import qualified Data.ByteString.Char8 as B8
#endif

-- | Equality depends on 'value' and 'tag', not 'style'.
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

ge :: (MonadIO m, MonadFailure YamlException m, IsYamlScalar k,
       IsYamlScalar v)
   => Object k v
   -> YamlEncoder m ()
ge yo = emitEvent EventStreamStart >> emitEvent EventDocumentStart
     >> geO yo >> emitEvent EventDocumentEnd >> emitEvent EventStreamEnd

geO :: (MonadIO m, MonadFailure YamlException m, IsYamlScalar k,
        IsYamlScalar v)
    => Object k v
    -> YamlEncoder m ()
geO (Scalar s) = geS s
geO (Sequence yos) = emitEvent EventSequenceStart
                  >> mapM_ geO yos
                  >> emitEvent EventSequenceEnd
geO (Mapping pairs) = emitEvent EventMappingStart
                   >> mapM_ gePair pairs
                   >> emitEvent EventMappingEnd

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 = geYS . toYamlScalar

geYS :: (MonadIO m, MonadFailure YamlException m)
     => YamlScalar
     -> YamlEncoder m ()
geYS (YamlScalar v t s) = emitEvent $ 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