{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Object.Yaml
    ( -- * 'YamlDoc' definition and IO
      YamlDoc (..)
    , readYamlDoc
    , writeYamlDoc
      -- * 'YamlObject' definition
    , YamlScalar (..)
    , Tag (..)
    , Style (..)
    , YamlObject
      -- * Performing conversions
    , eventsToYamlObject
      -- * Exceptions
    , YamlException (..)
      -- * Re-export
    , 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
    -- Note: the join here will swallow up 'YamlException's.
    -- However, these should never occur, as that would imply an error
    -- in the C library or bindings.
    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)
    ])

-- FIXME add Scalar instances
{-
instance ConvertSuccess YamlScalar Scalar where
    convertSuccess = Text . convertSuccess
instance ConvertSuccess Scalar YamlScalar where
    convertSuccess s = convertSuccess (convertSuccess s :: Text)
-}

type YamlObject = Object YamlScalar YamlScalar

$(deriveSuccessConvs ''YamlScalar ''YamlScalar
    [''String, ''Text]
    [''String, ''Text])

$(deriveSuccessConvs ''String ''String [''YamlScalar] [''YamlScalar])
$(deriveSuccessConvs ''Text ''Text [''YamlScalar] [''YamlScalar])

-- Emit a YamlObject to an event stream
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

-- | Parse a YamlObject from an event stream
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)

{- FIXME
instance ConvertSuccess (Object YamlScalar YamlScalar) (Object String Scalar) where
    convertSuccess = mapKeysValues convertSuccess convertSuccess
instance ConvertSuccess (Object String Scalar) (Object YamlScalar YamlScalar) where
    convertSuccess = mapKeysValues convertSuccess convertSuccess
-}

#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''

{-
-- FIXME remove the following
instance ToObject [(String, String)] Text Text where
    toObject = Mapping . map (cs *** toObject)
instance ToObject [(ByteString, ByteString)] Text Text where
    toObject = Mapping . map (cs *** toObject)
instance ToObject [(BL.ByteString, BL.ByteString)] Text Text where
    toObject = Mapping . map (cs *** toObject)
instance ToObject [(String, TextObject)] Text Text where
    toObject = Mapping . map (cs *** id)
-}

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