{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}

module DPM.Core.DPM_Monad (

  DPMConfig(..), DPM, DPMException(..),

  runDPM, bracketDPM, failIO, asIO, liftIO, debugDPM,

  DPMConfigAccess(..)

) where

import Prelude hiding ( catch )
import Control.Monad
import Control.Monad.Reader
import Control.Exception
import System.FilePath
import System.IO
import Data.Typeable

data DPMConfig = DPMConfig { cfg_modelFile       :: FilePath
                           , cfg_patchesFile     :: FilePath
                           , cfg_dataDir         :: FilePath
                           , cfg_currentUser     :: String
                           , cfg_fromAddress     :: String
                           , cfg_reviewAddress   :: Maybe String
                           , cfg_patchLog        :: FilePath
                           , cfg_patchGroupLog   :: FilePath
                           , cfg_lockFile        :: FilePath
                           , cfg_reviewDir       :: FilePath
                           , cfg_repoDir         :: FilePath
                           , cfg_debug           :: Bool }

newtype DPM a = DPM { unDPM :: (ReaderT DPMConfig IO a) }

data DPMException = DPMException String
                  deriving (Show,Read,Eq,Typeable)

instance Exception DPMException where

instance Monad DPM where
    DPM a >>= f = DPM (a >>= (unDPM . f))
    return = DPM . return
    fail errMsg = liftIO' $ throwIO (DPMException errMsg)

failIO :: String -> IO a
failIO errMsg = throwIO (DPMException errMsg)

instance MonadIO DPM where
    liftIO io =
        do r <- liftIO' (do x <- io
                            return (Right x)
                         `catch`
                         (\(e::IOException) -> return (Left (show e))))
           case r of
             Right x -> return x
             Left err -> fail ("I/O command failed: " ++ err)

liftIO' :: IO a -> DPM a
liftIO' io = DPM (liftIO io)

runDPM :: DPMConfig -> DPM a -> IO a
runDPM cfg (DPM r) = runReaderT r cfg

bracketDPM :: DPM a -> (a -> DPM c) -> (a -> DPM c) -> DPM c
bracketDPM acquire release doWork =
    do config <- getDPMConfig
       liftIO $ bracket (run acquire config)
                        (\x -> run (release x) config)
                        (\x -> run (doWork x) config)
   where run = runReaderT . unDPM

asIO :: DPM a -> DPM (IO a)
asIO (DPM x) =
    do config <- getDPMConfig
       return $ runReaderT x config

class Monad m => DPMConfigAccess m where
    getDPMConfig :: m DPMConfig
    getDPMConfigValue :: (DPMConfig -> a) -> m a
    getDPMConfigValue f =
        do config <- getDPMConfig
           return (f config)

instance DPMConfigAccess DPM where
    getDPMConfig = DPM ask

debugDPM :: String -> DPM ()
debugDPM s = 
    do b <- getDPMConfigValue cfg_debug
       when b $ liftIO $ hPutStrLn stderr ("[DPM Debug] " ++ s)