{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module DPM.UI.Commandline.CDPM_Monad (

  Config(..), defaultConfig, CDPM, runCDPM,
  liftDPM, bracketCDPM, asDPM, funAsDPM,

  getConfig, getConfigValue, debugCDPM,

  withLock

) where

import Control.Monad.Reader

import DPM.Core.DPM_Monad
import qualified DPM.Core.Storage as S

import DPM.UI.Commandline.ANSIColors

data Config = Config { cfg_verbose    :: Bool
                     , cfg_batch      :: Bool
                     , cfg_tests      :: Bool
                     , cfg_force      :: Bool
                     , cfg_color1     :: Color
                     , cfg_color2     :: Color
                     , cfg_color3     :: Color
                     , cfg_colored    :: Bool }

defaultConfig :: Config
defaultConfig = Config { cfg_verbose    = False
                       , cfg_batch      = False
                       , cfg_tests      = True
                       , cfg_force      = False
                       , cfg_color1     = Red
                       , cfg_color2     = Blue
                       , cfg_color3     = Green
                       , cfg_colored    = True }

newtype CDPM a = CDPM { unCDPM :: ReaderT Config DPM a }
               deriving (Monad, MonadIO)

runCDPM :: Config -> CDPM a -> DPM a
runCDPM cfg (CDPM r) = runReaderT r cfg

liftDPM :: DPM a -> CDPM a
liftDPM dpm = CDPM (lift dpm)

bracketCDPM :: CDPM a -> (a -> CDPM c) -> (a -> CDPM c) -> CDPM c
bracketCDPM acquire release doWork =
    do config <- getConfig
       liftDPM $ bracketDPM (run acquire config)
                            (\x -> run (release x) config)
                            (\x -> run (doWork x) config)
   where run = runReaderT . unCDPM

asDPM :: CDPM a -> CDPM (DPM a)
asDPM (CDPM x) =
    do config <- getConfig
       return $ runReaderT x config

funAsDPM :: (a -> CDPM b) -> CDPM (a -> DPM b)
funAsDPM f =
    do cfg <- getConfig
       return $ \x -> runReaderT (unCDPM (f x)) cfg

withLock :: CDPM a -> CDPM a
withLock cdpm =
    do dpm <- asDPM cdpm
       liftDPM (S.withLock dpm)


getConfig :: CDPM Config
getConfig = CDPM ask

getConfigValue :: (Config -> a) -> CDPM a
getConfigValue f =
    do cfg <- getConfig
       return (f cfg)

instance DPMConfigAccess CDPM where
    getDPMConfig = liftDPM getDPMConfig

debugCDPM :: String -> CDPM ()
debugCDPM = liftDPM . debugDPM