{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module RIO.App
( App(..)
, SetupApp
, appMain
, nestApp
) where
import RIO
import Control.Monad.Trans.Resource (MonadResource(..))
import qualified Control.Monad.Trans.Resource as ResourceT
import RIO.Process (HasProcessContext(..), ProcessContext, mkDefaultProcessContext)
data App env st = App
{ App env st -> LogFunc
appLogFunc :: LogFunc
, App env st -> ProcessContext
appProcessContext :: ProcessContext
, App env st -> InternalState
appResources :: ResourceT.InternalState
, App env st -> env
appEnv :: env
, App env st -> SomeRef st
appState :: SomeRef st
}
instance HasLogFunc (App env st) where
logFuncL :: (LogFunc -> f LogFunc) -> App env st -> f (App env st)
logFuncL =
(App env st -> LogFunc)
-> (App env st -> LogFunc -> App env st)
-> Lens' (App env st) LogFunc
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
App env st -> LogFunc
forall env st. App env st -> LogFunc
appLogFunc
\App env st
x LogFunc
y -> App env st
x{appLogFunc :: LogFunc
appLogFunc = LogFunc
y}
instance HasProcessContext (App env st) where
processContextL :: (ProcessContext -> f ProcessContext)
-> App env st -> f (App env st)
processContextL =
(App env st -> ProcessContext)
-> (App env st -> ProcessContext -> App env st)
-> Lens' (App env st) ProcessContext
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
App env st -> ProcessContext
forall env st. App env st -> ProcessContext
appProcessContext
\App env st
x ProcessContext
y -> App env st
x{appProcessContext :: ProcessContext
appProcessContext = ProcessContext
y}
instance MonadResource (RIO (App env st)) where
liftResourceT :: ResourceT IO a -> RIO (App env st) a
liftResourceT ResourceT IO a
action =
(App env st -> InternalState) -> RIO (App env st) InternalState
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks App env st -> InternalState
forall env st. App env st -> InternalState
appResources RIO (App env st) InternalState
-> (InternalState -> RIO (App env st) a) -> RIO (App env st) a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
IO a -> RIO (App env st) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> RIO (App env st) a)
-> (InternalState -> IO a) -> InternalState -> RIO (App env st) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceT IO a -> InternalState -> IO a
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
ResourceT.runInternalState ResourceT IO a
action
instance HasStateRef st (App env st) where
stateRefL :: (SomeRef st -> f (SomeRef st)) -> App env st -> f (App env st)
stateRefL =
(App env st -> SomeRef st)
-> (App env st -> SomeRef st -> App env st)
-> Lens' (App env st) (SomeRef st)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
App env st -> SomeRef st
forall env st. App env st -> SomeRef st
appState
\App env st
x SomeRef st
y -> App env st
x{appState :: SomeRef st
appState = SomeRef st
y}
type SetupApp = App () ()
appMain
:: IO options
-> (options -> Bool)
-> (options -> RIO SetupApp (env, st))
-> RIO (App env st) ()
-> IO ()
appMain :: IO options
-> (options -> Bool)
-> (options -> RIO SetupApp (env, st))
-> RIO (App env st) ()
-> IO ()
appMain IO options
parseOptions options -> Bool
verbose options -> RIO SetupApp (env, st)
setup RIO (App env st) ()
run = do
options
options <- IO options
parseOptions
LogOptions
logFunc <- Handle -> Bool -> IO LogOptions
forall (m :: * -> *). MonadIO m => Handle -> Bool -> m LogOptions
logOptionsHandle Handle
stderr (options -> Bool
verbose options
options)
ProcessContext
appProcessContext <- IO ProcessContext
forall (m :: * -> *). MonadIO m => m ProcessContext
mkDefaultProcessContext
SomeRef ()
stateRef <- () -> IO (SomeRef ())
forall (m :: * -> *) a. MonadIO m => a -> m (SomeRef a)
newSomeRef ()
LogOptions -> (LogFunc -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
LogOptions -> (LogFunc -> m a) -> m a
withLogFunc LogOptions
logFunc \LogFunc
appLogFunc ->
IO InternalState
-> (InternalState -> IO ()) -> (InternalState -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket IO InternalState
forall (m :: * -> *). MonadIO m => m InternalState
ResourceT.createInternalState InternalState -> IO ()
forall (m :: * -> *). MonadIO m => InternalState -> m ()
ResourceT.closeInternalState \InternalState
appResources -> do
let
setupApp :: SetupApp
setupApp = App :: forall env st.
LogFunc
-> ProcessContext
-> InternalState
-> env
-> SomeRef st
-> App env st
App
{ appEnv :: ()
appEnv = ()
, appState :: SomeRef ()
appState = SomeRef ()
stateRef
, InternalState
ProcessContext
LogFunc
appResources :: InternalState
appLogFunc :: LogFunc
appProcessContext :: ProcessContext
appResources :: InternalState
appProcessContext :: ProcessContext
appLogFunc :: LogFunc
..
}
SetupApp -> RIO SetupApp () -> IO ()
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO SetupApp
setupApp (RIO SetupApp () -> IO ()) -> RIO SetupApp () -> IO ()
forall a b. (a -> b) -> a -> b
$
RIO SetupApp (env, st) -> RIO (App env st) () -> RIO SetupApp ()
forall (m :: * -> *) env st innerEnv innerSt a.
(MonadUnliftIO m, MonadReader (App env st) m) =>
RIO (App env st) (innerEnv, innerSt)
-> RIO (App innerEnv innerSt) a -> m a
nestApp (options -> RIO SetupApp (env, st)
setup options
options) RIO (App env st) ()
run
nestApp
:: (MonadUnliftIO m, MonadReader (App env st) m)
=> RIO (App env st) (innerEnv, innerSt)
-> RIO (App innerEnv innerSt) a
-> m a
nestApp :: RIO (App env st) (innerEnv, innerSt)
-> RIO (App innerEnv innerSt) a -> m a
nestApp RIO (App env st) (innerEnv, innerSt)
setupNext RIO (App innerEnv innerSt) a
action =
m InternalState
-> (InternalState -> m ()) -> (InternalState -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m InternalState
forall (m :: * -> *). MonadIO m => m InternalState
ResourceT.createInternalState InternalState -> m ()
forall (m :: * -> *). MonadIO m => InternalState -> m ()
ResourceT.closeInternalState \InternalState
nestedResources -> do
App env st
oldApp <- m (App env st)
forall r (m :: * -> *). MonadReader r m => m r
ask
(innerEnv
innerEnv, innerSt
innerState) <- App env st
-> RIO (App env st) (innerEnv, innerSt) -> m (innerEnv, innerSt)
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO
App env st
oldApp{appResources :: InternalState
appResources=InternalState
nestedResources}
RIO (App env st) (innerEnv, innerSt)
setupNext
SomeRef innerSt
innerStateRef <- innerSt -> m (SomeRef innerSt)
forall (m :: * -> *) a. MonadIO m => a -> m (SomeRef a)
newSomeRef innerSt
innerState
let
nextApp :: App innerEnv innerSt
nextApp = App env st
oldApp
{ appResources :: InternalState
appResources = InternalState
nestedResources
, appEnv :: innerEnv
appEnv = innerEnv
innerEnv
, appState :: SomeRef innerSt
appState = SomeRef innerSt
innerStateRef
}
App innerEnv innerSt -> RIO (App innerEnv innerSt) a -> m a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO App innerEnv innerSt
nextApp RIO (App innerEnv innerSt) a
action