{-# options_haddock prune #-}

-- |CLI, Internal
module Helic.Cli where

import Options.Applicative (customExecParser, fullDesc, header, helper, info, prefs, showHelpOnEmpty, showHelpOnError)
import Polysemy.Chronos (interpretTimeChronos)
import qualified Polysemy.Conc as Conc
import Polysemy.Conc (
  interpretCritical,
  interpretInterrupt,
  interpretRace,
  )
import Polysemy.Log (
  LogEntry,
  LogMessage,
  Logger,
  Severity (Info, Trace),
  formatLogEntry,
  interceptDataLogConc,
  interpretDataLogStdoutWith,
  interpretLogDataLog,
  setLogLevel,
  )
import qualified Polysemy.Log.Data.DataLog as DataLog
import Polysemy.Time (GhcTime, MilliSeconds (MilliSeconds), interpretTimeGhc)
import System.IO (hLookAhead, stdin)

import Helic.App (AppStack, IOStack, listApp, listenApp, loadApp, yankApp)
import Helic.Cli.Options (Command (List, Listen, Load, Yank), Conf (Conf), parser)
import Helic.Config.File (findFileConfig)
import qualified Helic.Data.Config as Config
import Helic.Data.Config (Config)
import Helic.Data.YankConfig (YankConfig (YankConfig))

logError ::
  Members [Logger, GhcTime, Final IO] r =>
  Sem (Error Text : r) () ->
  Sem r ()
logError :: Sem (Error Text : r) () -> Sem r ()
logError =
  (Text -> Sem r ())
-> (() -> Sem r ()) -> Either Text () -> Sem r ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Members '[Logger, GhcTime] r) =>
Text -> Sem r ()
DataLog.error () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text () -> Sem r ())
-> (Sem (Error Text : r) () -> Sem r (Either Text ()))
-> Sem (Error Text : r) ()
-> Sem r ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Sem (Error Text : r) () -> Sem r (Either Text ())
forall e (r :: EffectRow) a.
(Typeable e, Member (Final IO) r) =>
Sem (Error e : r) a -> Sem r (Either e a)
errorToIOFinal

interpretLog ::
  Maybe Bool ->
  InterpreterFor Log IOStack
interpretLog :: Maybe Bool -> InterpreterFor Log IOStack
interpretLog (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False -> Bool
verbose) =
  Maybe Severity -> Sem IOStack a -> Sem IOStack a
forall (r :: EffectRow) a.
Member Logger r =>
Maybe Severity -> Sem r a -> Sem r a
setLogLevel (if Bool
verbose then Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
Trace else Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
Info) (Sem IOStack a -> Sem IOStack a)
-> (Sem (Log : IOStack) a -> Sem IOStack a)
-> Sem (Log : IOStack) a
-> Sem IOStack a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Log : IOStack) a -> Sem IOStack a
forall (r :: EffectRow).
Members '[Logger, GhcTime] r =>
InterpreterFor Log r
interpretLogDataLog

runIO ::
  Sem IOStack () ->
  IO ()
runIO :: Sem IOStack () -> IO ()
runIO =
  Sem '[Final IO] () -> IO ()
forall (m :: * -> *) a. Monad m => Sem '[Final m] a -> m a
runFinal (Sem '[Final IO] () -> IO ())
-> (Sem IOStack () -> Sem '[Final IO] ())
-> Sem IOStack ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem '[Embed IO, Final IO] () -> Sem '[Final IO] ()
forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
Sem (Embed m : r) a -> Sem r a
embedToFinal (Sem '[Embed IO, Final IO] () -> Sem '[Final IO] ())
-> (Sem IOStack () -> Sem '[Embed IO, Final IO] ())
-> Sem IOStack ()
-> Sem '[Final IO] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem '[Resource, Embed IO, Final IO] ()
-> Sem '[Embed IO, Final IO] ()
forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (Resource : r) a -> Sem r a
resourceToIOFinal (Sem '[Resource, Embed IO, Final IO] ()
 -> Sem '[Embed IO, Final IO] ())
-> (Sem IOStack () -> Sem '[Resource, Embed IO, Final IO] ())
-> Sem IOStack ()
-> Sem '[Embed IO, Final IO] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem '[Async, Resource, Embed IO, Final IO] ()
-> Sem '[Resource, Embed IO, Final IO] ()
forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (Async : r) a -> Sem r a
asyncToIOFinal (Sem '[Async, Resource, Embed IO, Final IO] ()
 -> Sem '[Resource, Embed IO, Final IO] ())
-> (Sem IOStack ()
    -> Sem '[Async, Resource, Embed IO, Final IO] ())
-> Sem IOStack ()
-> Sem '[Resource, Embed IO, Final IO] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem '[Race, Async, Resource, Embed IO, Final IO] ()
-> Sem '[Async, Resource, Embed IO, Final IO] ()
forall (r :: EffectRow).
Member (Final IO) r =>
InterpreterFor Race r
interpretRace (Sem '[Race, Async, Resource, Embed IO, Final IO] ()
 -> Sem '[Async, Resource, Embed IO, Final IO] ())
-> (Sem IOStack ()
    -> Sem '[Race, Async, Resource, Embed IO, Final IO] ())
-> Sem IOStack ()
-> Sem '[Async, Resource, Embed IO, Final IO] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem '[GhcTime, Race, Async, Resource, Embed IO, Final IO] ()
-> Sem '[Race, Async, Resource, Embed IO, Final IO] ()
forall (r :: EffectRow).
Member (Embed IO) r =>
InterpreterFor GhcTime r
interpretTimeGhc (Sem '[GhcTime, Race, Async, Resource, Embed IO, Final IO] ()
 -> Sem '[Race, Async, Resource, Embed IO, Final IO] ())
-> (Sem IOStack ()
    -> Sem '[GhcTime, Race, Async, Resource, Embed IO, Final IO] ())
-> Sem IOStack ()
-> Sem '[Race, Async, Resource, Embed IO, Final IO] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem
  '[ChronosTime, GhcTime, Race, Async, Resource, Embed IO, Final IO]
  ()
-> Sem '[GhcTime, Race, Async, Resource, Embed IO, Final IO] ()
forall (r :: EffectRow).
Member (Embed IO) r =>
InterpreterFor ChronosTime r
interpretTimeChronos (Sem
   '[ChronosTime, GhcTime, Race, Async, Resource, Embed IO, Final IO]
   ()
 -> Sem '[GhcTime, Race, Async, Resource, Embed IO, Final IO] ())
-> (Sem IOStack ()
    -> Sem
         '[ChronosTime, GhcTime, Race, Async, Resource, Embed IO, Final IO]
         ())
-> Sem IOStack ()
-> Sem '[GhcTime, Race, Async, Resource, Embed IO, Final IO] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem
  '[Critical, ChronosTime, GhcTime, Race, Async, Resource, Embed IO,
    Final IO]
  ()
-> Sem
     '[ChronosTime, GhcTime, Race, Async, Resource, Embed IO, Final IO]
     ()
forall (r :: EffectRow).
Member (Final IO) r =>
InterpreterFor Critical r
interpretCritical (Sem
   '[Critical, ChronosTime, GhcTime, Race, Async, Resource, Embed IO,
     Final IO]
   ()
 -> Sem
      '[ChronosTime, GhcTime, Race, Async, Resource, Embed IO, Final IO]
      ())
-> (Sem IOStack ()
    -> Sem
         '[Critical, ChronosTime, GhcTime, Race, Async, Resource, Embed IO,
           Final IO]
         ())
-> Sem IOStack ()
-> Sem
     '[ChronosTime, GhcTime, Race, Async, Resource, Embed IO, Final IO]
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem
  '[Interrupt, Critical, ChronosTime, GhcTime, Race, Async, Resource,
    Embed IO, Final IO]
  ()
-> Sem
     '[Critical, ChronosTime, GhcTime, Race, Async, Resource, Embed IO,
       Final IO]
     ()
forall (r :: EffectRow).
Members '[Critical, Race, Async, Embed IO] r =>
InterpreterFor Interrupt r
interpretInterrupt (Sem
   '[Interrupt, Critical, ChronosTime, GhcTime, Race, Async, Resource,
     Embed IO, Final IO]
   ()
 -> Sem
      '[Critical, ChronosTime, GhcTime, Race, Async, Resource, Embed IO,
        Final IO]
      ())
-> (Sem IOStack ()
    -> Sem
         '[Interrupt, Critical, ChronosTime, GhcTime, Race, Async, Resource,
           Embed IO, Final IO]
         ())
-> Sem IOStack ()
-> Sem
     '[Critical, ChronosTime, GhcTime, Race, Async, Resource, Embed IO,
       Final IO]
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (LogEntry LogMessage -> Text)
-> InterpreterFor
     Logger
     '[Interrupt, Critical, ChronosTime, GhcTime, Race, Async, Resource,
       Embed IO, Final IO]
forall (r :: EffectRow) a.
Member (Embed IO) r =>
(a -> Text) -> InterpreterFor (DataLog a) r
interpretDataLogStdoutWith LogEntry LogMessage -> Text
formatLogEntry (Sem
   '[Logger, Interrupt, Critical, ChronosTime, GhcTime, Race, Async,
     Resource, Embed IO, Final IO]
   ()
 -> Sem
      '[Interrupt, Critical, ChronosTime, GhcTime, Race, Async, Resource,
        Embed IO, Final IO]
      ())
-> (Sem IOStack ()
    -> Sem
         '[Logger, Interrupt, Critical, ChronosTime, GhcTime, Race, Async,
           Resource, Embed IO, Final IO]
         ())
-> Sem IOStack ()
-> Sem
     '[Interrupt, Critical, ChronosTime, GhcTime, Race, Async, Resource,
       Embed IO, Final IO]
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int
-> Sem
     '[Logger, Interrupt, Critical, ChronosTime, GhcTime, Race, Async,
       Resource, Embed IO, Final IO]
     ()
-> Sem
     '[Logger, Interrupt, Critical, ChronosTime, GhcTime, Race, Async,
       Resource, Embed IO, Final IO]
     ()
forall msg (r :: EffectRow) a.
Members '[DataLog msg, Resource, Async, Race, Embed IO] r =>
Int -> Sem r a -> Sem r a
interceptDataLogConc @(LogEntry LogMessage) Int
64 (Sem
   '[Logger, Interrupt, Critical, ChronosTime, GhcTime, Race, Async,
     Resource, Embed IO, Final IO]
   ()
 -> Sem
      '[Logger, Interrupt, Critical, ChronosTime, GhcTime, Race, Async,
        Resource, Embed IO, Final IO]
      ())
-> (Sem IOStack ()
    -> Sem
         '[Logger, Interrupt, Critical, ChronosTime, GhcTime, Race, Async,
           Resource, Embed IO, Final IO]
         ())
-> Sem IOStack ()
-> Sem
     '[Logger, Interrupt, Critical, ChronosTime, GhcTime, Race, Async,
       Resource, Embed IO, Final IO]
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem IOStack ()
-> Sem
     '[Logger, Interrupt, Critical, ChronosTime, GhcTime, Race, Async,
       Resource, Embed IO, Final IO]
     ()
forall (r :: EffectRow).
Members '[Logger, GhcTime, Final IO] r =>
Sem (Error Text : r) () -> Sem r ()
logError

runCommand :: Config -> Command -> Sem AppStack ()
runCommand :: Config -> Command -> Sem (Log : IOStack) ()
runCommand Config
config = \case
  Command
Listen ->
    Config -> Sem (Log : IOStack) ()
listenApp Config
config
  Yank YankConfig
yankConf ->
    Config -> YankConfig -> Sem (Log : IOStack) ()
yankApp Config
config YankConfig
yankConf
  List ListConfig
showConf ->
    Config -> ListConfig -> Sem (Log : IOStack) ()
listApp Config
config ListConfig
showConf
  Load LoadConfig
loadConf ->
    Config -> LoadConfig -> Sem (Log : IOStack) ()
loadApp Config
config LoadConfig
loadConf

defaultCommand :: Sem IOStack Command
defaultCommand :: Sem IOStack Command
defaultCommand = do
  Sem IOStack (Maybe (Either Text Char))
-> MilliSeconds
-> Sem IOStack (Maybe (Either Text Char))
-> Sem IOStack (Maybe (Either Text Char))
forall u (r :: EffectRow) a.
(TimeUnit u, Member Race r) =>
Sem r a -> u -> Sem r a -> Sem r a
Conc.timeout_ (Maybe (Either Text Char) -> Sem IOStack (Maybe (Either Text Char))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either Text Char)
forall a. Maybe a
Nothing) (Int64 -> MilliSeconds
MilliSeconds Int64
100) (Either Text Char -> Maybe (Either Text Char)
forall a. a -> Maybe a
Just (Either Text Char -> Maybe (Either Text Char))
-> Sem IOStack (Either Text Char)
-> Sem IOStack (Maybe (Either Text Char))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Char -> Sem IOStack (Either Text Char)
forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Either Text a)
tryAny (Handle -> IO Char
hLookAhead Handle
stdin)) Sem IOStack (Maybe (Either Text Char))
-> (Maybe (Either Text Char) -> Command) -> Sem IOStack Command
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Just (Right Char
_) -> YankConfig -> Command
Yank (Maybe Text -> YankConfig
YankConfig (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"cli"))
    Maybe (Either Text Char)
_ -> Command
Listen

withCliOptions :: Conf -> Maybe Command -> IO ()
withCliOptions :: Conf -> Maybe Command -> IO ()
withCliOptions (Conf Maybe Bool
cliVerbose Maybe (Path Abs File)
file) Maybe Command
cmd =
  Sem IOStack () -> IO ()
runIO do
    Config
config <- Maybe Bool -> Sem (Log : IOStack) Config -> Sem IOStack Config
Maybe Bool -> InterpreterFor Log IOStack
interpretLog Maybe Bool
cliVerbose (Maybe (Path Abs File) -> Sem (Log : IOStack) Config
forall (r :: EffectRow).
Members '[Log, Error Text, Embed IO] r =>
Maybe (Path Abs File) -> Sem r Config
findFileConfig Maybe (Path Abs File)
file)
    Command
cmd' <- Sem IOStack Command
-> (Command -> Sem IOStack Command)
-> Maybe Command
-> Sem IOStack Command
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Sem IOStack Command
defaultCommand Command -> Sem IOStack Command
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Command
cmd
    Maybe Bool -> Sem (Log : IOStack) () -> Sem IOStack ()
Maybe Bool -> InterpreterFor Log IOStack
interpretLog (Maybe Bool
cliVerbose Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe Bool
Config.verbose Config
config) (Config -> Command -> Sem (Log : IOStack) ()
runCommand Config
config Command
cmd')

app :: IO ()
app :: IO ()
app = do
  (Conf
conf, Maybe Command
cmd) <- ParserPrefs
-> ParserInfo (Conf, Maybe Command) -> IO (Conf, Maybe Command)
forall a. ParserPrefs -> ParserInfo a -> IO a
customExecParser ParserPrefs
parserPrefs (Parser (Conf, Maybe Command)
-> InfoMod (Conf, Maybe Command)
-> ParserInfo (Conf, Maybe Command)
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser (Conf, Maybe Command)
parser Parser (Conf, Maybe Command)
-> Parser ((Conf, Maybe Command) -> (Conf, Maybe Command))
-> Parser (Conf, Maybe Command)
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser ((Conf, Maybe Command) -> (Conf, Maybe Command))
forall a. Parser (a -> a)
helper) InfoMod (Conf, Maybe Command)
forall a. InfoMod a
desc)
  Conf -> Maybe Command -> IO ()
withCliOptions Conf
conf Maybe Command
cmd
  where
    parserPrefs :: ParserPrefs
parserPrefs =
      PrefsMod -> ParserPrefs
prefs (PrefsMod
showHelpOnEmpty PrefsMod -> PrefsMod -> PrefsMod
forall a. Semigroup a => a -> a -> a
<> PrefsMod
showHelpOnError)
    desc :: InfoMod a
desc =
      InfoMod a
forall a. InfoMod a
fullDesc InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
header String
"Helic is a clipboard synchronization tool."