module B9.Invokation ( B9Invokation()
, invokeB9
, overrideWorkingDirectory
, mergeAfterConfigurationActionResults
, ignoreActionResults
, doAfterConfiguration
, overrideB9ConfigPath
, modifyInvokationConfig
, modifyPermanentConfig) where
import B9.B9Config
import Data.ConfigFile.B9Extras
import Control.Monad.IO.Class
import Control.Monad.State
import Control.Monad.Reader
import Control.Lens
import Control.Exception (bracket)
import System.Directory (getCurrentDirectory, setCurrentDirectory)
import Data.Semigroup as Sem
import Data.Maybe (fromMaybe)
import Text.Printf ( printf )
newtype B9Invokation res a = B9Inv {runB9Invokation :: StateT (InternalState res) IO a}
deriving (MonadState (InternalState res), Monad, Applicative, Functor, MonadIO)
data InternalState a = IS { _initialConfigOverride :: B9ConfigOverride
, _permanentB9ConfigUpdate :: Maybe (ConfigParser -> Either CPError ConfigParser)
, _changeWorkingDirectory :: Maybe FilePath
, _buildAction :: Maybe (ReaderT B9Config IO a)
}
makeLenses ''InternalState
initialState :: InternalState a
initialState = IS (B9ConfigOverride Nothing mempty) Nothing Nothing Nothing
invokeB9 :: B9Invokation res () -> IO (Maybe res)
invokeB9 act = do
st <- execStateT (runB9Invokation act) initialState
let cfgPath = st ^. initialConfigOverride . customB9ConfigPath
cp0 <- openOrCreateB9Config cfgPath
let cpExtErr = fmap ($ cp0) (st ^. permanentB9ConfigUpdate)
cpExt <- maybe
(return Nothing)
( either
( fail
. printf "Internal configuration error! Please report this: %s\n"
. show
)
(return . Just)
)
cpExtErr
let cp = fromMaybe cp0 cpExt
mapM_ (writeB9ConfigParser cfgPath) cpExt
case parseB9Config cp of
Left e -> fail (printf "Configuration error: %s\n" (show e))
Right permanentConfig -> do
let
runtimeCfg =
permanentConfig
Sem.<> st
^. initialConfigOverride
. customB9Config
completeBuildAction = bracket
getCurrentDirectory
setCurrentDirectory
( const
( do
mapM_ setCurrentDirectory
(st ^. changeWorkingDirectory)
runReaderT (sequence (st ^. buildAction)) runtimeCfg
)
)
completeBuildAction
doAfterConfiguration :: (Maybe a -> ReaderT B9Config IO a) -> B9Invokation a ()
doAfterConfiguration action = buildAction %= appendOrSet
where
appendOrSet Nothing = Just (action Nothing)
appendOrSet (Just x) = Just (x >>= action . Just)
mergeAfterConfigurationActionResults
:: (Maybe a -> Maybe b -> ReaderT B9Config IO b)
-> B9Invokation a ()
-> B9Invokation b ()
mergeAfterConfigurationActionResults f ba = do
st <- liftIO $ execStateT (runB9Invokation ba) initialState
let fb mbAction = Just $ do
ma <- sequence (st ^. buildAction)
mb <- sequence mbAction
f ma mb
buildAction %= fb
ignoreActionResults :: B9Invokation a () -> B9Invokation () ()
ignoreActionResults =
mergeAfterConfigurationActionResults (const (const (return ())))
overrideB9ConfigPath :: SystemPath -> B9Invokation a ()
overrideB9ConfigPath p = initialConfigOverride . customB9ConfigPath .= Just p
overrideWorkingDirectory :: FilePath -> B9Invokation a ()
overrideWorkingDirectory p = changeWorkingDirectory .= Just p
modifyInvokationConfig :: (B9Config -> B9Config) -> B9Invokation a ()
modifyInvokationConfig f = initialConfigOverride . customB9Config %= f
modifyPermanentConfig :: (B9Config -> B9Config) -> B9Invokation a ()
modifyPermanentConfig g = permanentB9ConfigUpdate %= go
where
go Nothing = go (Just return)
go (Just f) = Just (\cp -> f cp >>= modifyConfigParser g)