{-# 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}

{- | Bootstrap environment.

Has logging and hold permanent resources, but no env and state of its own.
Used to setup initial environment and state, that can be derived from allocated resources.
-}
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