{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FunctionalDependencies #-}
module Web.VKHS.Monad where

import Data.List
import Data.Maybe
import Data.Time
import Data.Either
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Cont
import Data.Default.Class
import System.IO

import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS

import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text

import Web.VKHS.Error
import Web.VKHS.Types
import Web.VKHS.Client hiding(Error)
import qualified Web.VKHS.Client as Client


-- newtype VKT m r a = VKT { unVKT :: StateT (r -> VKT m r r) (ContT r m) a }
--   deriving(Functor, Applicative, Monad, MonadState (r -> VKT m r r), MonadCont, MonadIO)

class (MonadCont m, MonadReader (r -> m r) m) => MonadVK m r

-- instance (Monad m) => MonadVK (VKT m r) r

-- | Store early exit handler in the reader monad, run the computation @m@
catch :: (MonadVK m r) => m r -> m r
catch m = do
  callCC $ \k -> do
    local (const k) m

raise :: (MonadVK m r) => ((a -> m b) -> r) -> m a
raise z = callCC $ \k -> do
  err <- ask
  err (z k)
  undefined

terminate :: (MonadVK m r) => r -> m a
terminate r = do
  err <- ask
  err r
  undefined

-- | Request to the Superviser to log certain @text@
log_error :: MonadVK (t (R t a)) (Result t a) => Text -> t (R t a) ()
log_error text = raise (LogError text)

class MonadVK (t r) r => EnsureVK t r c a | c -> a where
  ensure :: t r c -> t r a

instance (MonadVK (t (R t x)) (R t x)) => EnsureVK t (R t x) (Either Client.Error Request) Request where
  ensure m  = m >>= \x ->
    case x of
      (Right u) -> return u
      (Left e) -> raise (\k -> UnexpectedRequest e k)

instance (MonadVK (t (R t x)) (R t x)) => EnsureVK t (R t x) (Either Client.Error URL) URL where
  ensure m  = m >>= \x ->
    case x of
      (Right u) -> return u
      (Left e) -> raise (\k -> UnexpectedURL e k)

debug :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m ()
debug str = do
  GenericOptions{..} <- gets toGenericOptions
  when o_verbose $ do
    liftIO $ Text.hPutStrLn stderr str

alert :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m ()
alert str = do
    liftIO $ Text.hPutStrLn stderr str