{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Provides functions for creating 'Env' from CLI/Toml configuration.
module Shrun.Configuration.Env
  ( -- * Running with Env
    withEnv,
    makeEnvAndShrun,

    -- * Misc
    getMergedConfig,
  )
where

import Data.Sequence qualified as Seq
import Data.Text qualified as T
import Effects.FileSystem.Utils qualified as FsUtils
import Shrun (runShellT, shrun)
import Shrun.Configuration (mergeConfig)
import Shrun.Configuration.Args.Parsing
  ( parserInfoArgs,
  )
import Shrun.Configuration.Data.Core qualified as CoreConfig
import Shrun.Configuration.Data.MergedConfig (MergedConfig)
import Shrun.Configuration.Data.WithDisabled
  ( WithDisabled (Disabled, With, Without),
  )
import Shrun.Configuration.Env.Types
  ( Env
      ( MkEnv,
        anyError,
        commands,
        completedCommands,
        config,
        consoleLogQueue
      ),
    HasConsoleLogging,
  )
import Shrun.Logging.MonadRegionLogger (MonadRegionLogger (Region))
import Shrun.Notify.MonadAppleScript (MonadAppleScript)
import Shrun.Notify.MonadDBus (MonadDBus)
import Shrun.Notify.MonadNotifySend (MonadNotifySend)
import Shrun.Prelude
import Shrun.ShellT (ShellT)

-- | 'withEnv' with 'shrun'.
makeEnvAndShrun ::
  forall m r.
  ( HasCallStack,
    HasConsoleLogging (Env r) (Region (ShellT (Env r) m)),
    MonadAppleScript m,
    MonadAsync m,
    MonadDBus m,
    MonadFileReader m,
    MonadFileWriter m,
    MonadHandleReader m,
    MonadHandleWriter m,
    MonadIORef m,
    MonadNotifySend m,
    MonadOptparse m,
    MonadPathReader m,
    MonadPathWriter m,
    MonadTypedProcess m,
    MonadMask m,
    MonadSTM m,
    MonadRegionLogger m,
    MonadTerminal m,
    MonadThread m,
    MonadTime m
  ) =>
  m ()
makeEnvAndShrun :: forall (m :: Type -> Type) r.
(HasCallStack,
 HasConsoleLogging (Env r) (Region (ShellT (Env r) m)),
 MonadAppleScript m, MonadAsync m, MonadDBus m, MonadFileReader m,
 MonadFileWriter m, MonadHandleReader m, MonadHandleWriter m,
 MonadIORef m, MonadNotifySend m, MonadOptparse m,
 MonadPathReader m, MonadPathWriter m, MonadTypedProcess m,
 MonadMask m, MonadSTM m, MonadRegionLogger m, MonadTerminal m,
 MonadThread m, MonadTime m) =>
m ()
makeEnvAndShrun = forall (m :: Type -> Type) r a.
(HasCallStack, MonadDBus m, MonadFileReader m, MonadFileWriter m,
 MonadHandleWriter m, MonadOptparse m, MonadPathReader m,
 MonadPathWriter m, MonadSTM m, MonadThrow m, MonadTerminal m) =>
(Env r -> m a) -> m a
withEnv @m @r (ShellT (Env r) m () -> Env r -> m ()
forall (m :: Type -> Type) env a. ShellT env m a -> env -> m a
runShellT ShellT (Env r) m ()
forall (m :: Type -> Type) env.
(HasAnyError env, HasCallStack, HasCommands env, HasInit env,
 HasCommandLogging env, HasCommonLogging env,
 HasConsoleLogging env (Region m), HasFileLogging env,
 HasNotifyConfig env, HasTimeout env, MonadAsync m,
 MonadHandleReader m, MonadHandleWriter m, MonadIORef m,
 MonadNotify m, MonadTypedProcess m, MonadMask m, MonadReader env m,
 MonadRegionLogger m, MonadSTM m, MonadThread m, MonadTime m) =>
m ()
shrun)

-- | Creates an 'Env' from CLI args and TOML config to run with a monadic
-- action.
withEnv ::
  forall m r a.
  ( HasCallStack,
    MonadDBus m,
    MonadFileReader m,
    MonadFileWriter m,
    MonadHandleWriter m,
    MonadOptparse m,
    MonadPathReader m,
    MonadPathWriter m,
    MonadSTM m,
    MonadThrow m,
    MonadTerminal m
  ) =>
  (Env r -> m a) ->
  m a
withEnv :: forall (m :: Type -> Type) r a.
(HasCallStack, MonadDBus m, MonadFileReader m, MonadFileWriter m,
 MonadHandleWriter m, MonadOptparse m, MonadPathReader m,
 MonadPathWriter m, MonadSTM m, MonadThrow m, MonadTerminal m) =>
(Env r -> m a) -> m a
withEnv Env r -> m a
onEnv = m MergedConfig
forall (m :: Type -> Type).
(HasCallStack, MonadDBus m, MonadFileReader m, MonadOptparse m,
 MonadPathReader m, MonadThrow m, MonadTerminal m) =>
m MergedConfig
getMergedConfig m MergedConfig -> (MergedConfig -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (MergedConfig -> (Env r -> m a) -> m a)
-> (Env r -> m a) -> MergedConfig -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip MergedConfig -> (Env r -> m a) -> m a
forall (m :: Type -> Type) r a.
(HasCallStack, MonadDBus m, MonadFileWriter m, MonadHandleWriter m,
 MonadPathReader m, MonadPathWriter m, MonadSTM m, MonadTerminal m,
 MonadThrow m) =>
MergedConfig -> (Env r -> m a) -> m a
fromMergedConfig Env r -> m a
onEnv

-- | Creates a 'MergedConfig' from CLI args and TOML config.
getMergedConfig ::
  ( HasCallStack,
    MonadDBus m,
    MonadFileReader m,
    MonadOptparse m,
    MonadPathReader m,
    MonadThrow m,
    MonadTerminal m
  ) =>
  m MergedConfig
getMergedConfig :: forall (m :: Type -> Type).
(HasCallStack, MonadDBus m, MonadFileReader m, MonadOptparse m,
 MonadPathReader m, MonadThrow m, MonadTerminal m) =>
m MergedConfig
getMergedConfig = do
  Args
args <- ParserInfo Args -> m Args
forall a. HasCallStack => ParserInfo a -> m a
forall (m :: Type -> Type) a.
(MonadOptparse m, HasCallStack) =>
ParserInfo a -> m a
execParser ParserInfo Args
parserInfoArgs

  Maybe Toml
mTomlConfig <-
    case Args
args Args
-> Optic' A_Lens NoIx Args (WithDisabled OsPath)
-> WithDisabled OsPath
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Args (WithDisabled OsPath)
#configPath of
      -- 1. If noConfig is true then we ignore all toml config
      WithDisabled OsPath
Disabled -> Maybe Toml -> m (Maybe Toml)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe Toml
forall a. Maybe a
Nothing
      -- 2. noConfig is false and toml config not set: try reading from
      --    default location. If it does not exist that's fine, just print
      --    a message. If it does, try to read it and throw any errors
      --    (e.g. file errors, toml errors).
      WithDisabled OsPath
Without -> do
        OsPath
configDir <- m OsPath
forall (m :: Type -> Type).
(HasCallStack, MonadPathReader m) =>
m OsPath
getShrunXdgConfig
        let path :: OsPath
path = OsPath
configDir OsPath -> OsPath -> OsPath
</> [osp|config.toml|]
        Bool
b <- OsPath -> m Bool
forall (m :: Type -> Type).
(MonadPathReader m, HasCallStack) =>
OsPath -> m Bool
doesFileExist OsPath
path
        if Bool
b
          then Toml -> Maybe Toml
forall a. a -> Maybe a
Just (Toml -> Maybe Toml) -> m Toml -> m (Maybe Toml)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> OsPath -> m Toml
forall {m :: Type -> Type} {b}.
(MonadFileReader m, MonadThrow m, DecodeTOML b) =>
OsPath -> m b
readConfig OsPath
path
          else do
            Text -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadTerminal m) =>
Text -> m ()
putTextLn
              ( Text
"No default config found at: "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (OsPath -> String
FsUtils.decodeOsToFpShow OsPath
path)
              )
            pure Maybe Toml
forall a. Maybe a
Nothing
      -- 3. noConfig is false and toml config explicitly set: try reading
      --    (all errors rethrown)
      With OsPath
f -> OsPath -> m (Maybe Toml)
forall {m :: Type -> Type} {b}.
(MonadFileReader m, MonadThrow m, DecodeTOML b) =>
OsPath -> m b
readConfig OsPath
f

  Args -> Maybe Toml -> m MergedConfig
forall (m :: Type -> Type).
(HasCallStack, MonadTerminal m, MonadThrow m) =>
Args -> Maybe Toml -> m MergedConfig
mergeConfig Args
args Maybe Toml
mTomlConfig
  where
    readConfig :: OsPath -> m b
readConfig OsPath
fp = do
      Text
contents <- OsPath -> m Text
forall (m :: Type -> Type).
(HasCallStack, MonadFileReader m, MonadThrow m) =>
OsPath -> m Text
readFileUtf8ThrowM OsPath
fp
      case Text -> Either TOMLError b
forall a. DecodeTOML a => Text -> Either TOMLError a
decode Text
contents of
        Right b
cfg -> b -> m b
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure b
cfg
        Left TOMLError
tomlErr -> TOMLError -> m b
forall (m :: Type -> Type) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM TOMLError
tomlErr

fromMergedConfig ::
  ( HasCallStack,
    MonadDBus m,
    MonadFileWriter m,
    MonadHandleWriter m,
    MonadPathReader m,
    MonadPathWriter m,
    MonadSTM m,
    MonadTerminal m,
    MonadThrow m
  ) =>
  MergedConfig ->
  (Env r -> m a) ->
  m a
fromMergedConfig :: forall (m :: Type -> Type) r a.
(HasCallStack, MonadDBus m, MonadFileWriter m, MonadHandleWriter m,
 MonadPathReader m, MonadPathWriter m, MonadSTM m, MonadTerminal m,
 MonadThrow m) =>
MergedConfig -> (Env r -> m a) -> m a
fromMergedConfig MergedConfig
cfg Env r -> m a
onEnv = do
  TVar (Seq CommandP1)
completedCommands <- Seq CommandP1 -> m (TVar (Seq CommandP1))
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
a -> m (TVar a)
newTVarA Seq CommandP1
forall a. Seq a
Seq.empty
  TVar Bool
anyError <- Bool -> m (TVar Bool)
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
a -> m (TVar a)
newTVarA Bool
False
  TBQueue (LogRegion r)
consoleLogQueue <- Natural -> m (TBQueue (LogRegion r))
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
Natural -> m (TBQueue a)
newTBQueueA Natural
1_000

  CoreConfigMerged -> (CoreConfigEnv -> m a) -> m a
forall (m :: Type -> Type) a.
(HasCallStack, MonadDBus m, MonadFileWriter m, MonadHandleWriter m,
 MonadPathReader m, MonadPathWriter m, MonadSTM m, MonadTerminal m,
 MonadThrow m) =>
CoreConfigMerged -> (CoreConfigEnv -> m a) -> m a
CoreConfig.withCoreEnv (MergedConfig
cfg MergedConfig
-> Optic' A_Lens NoIx MergedConfig CoreConfigMerged
-> CoreConfigMerged
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx MergedConfig CoreConfigMerged
#coreConfig) ((CoreConfigEnv -> m a) -> m a) -> (CoreConfigEnv -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \CoreConfigEnv
coreConfigEnv -> do
    let env :: Env r
env =
          MkEnv
            { config :: CoreConfigEnv
config = CoreConfigEnv
coreConfigEnv,
              TVar Bool
anyError :: TVar Bool
anyError :: TVar Bool
anyError,
              TVar (Seq CommandP1)
completedCommands :: TVar (Seq CommandP1)
completedCommands :: TVar (Seq CommandP1)
completedCommands,
              TBQueue (LogRegion r)
consoleLogQueue :: TBQueue (LogRegion r)
consoleLogQueue :: TBQueue (LogRegion r)
consoleLogQueue,
              commands :: NESeq CommandP1
commands = MergedConfig
cfg MergedConfig
-> Optic' A_Lens NoIx MergedConfig (NESeq CommandP1)
-> NESeq CommandP1
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx MergedConfig (NESeq CommandP1)
#commands
            }

    Env r -> m a
onEnv Env r
env

getShrunXdgConfig :: (HasCallStack, MonadPathReader m) => m OsPath
getShrunXdgConfig :: forall (m :: Type -> Type).
(HasCallStack, MonadPathReader m) =>
m OsPath
getShrunXdgConfig = OsPath -> m OsPath
forall (m :: Type -> Type).
(HasCallStack, MonadPathReader m) =>
OsPath -> m OsPath
getXdgConfig [osp|shrun|]