diff --git a/helic.cabal b/helic.cabal --- a/helic.cabal +++ b/helic.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: helic -version: 0.3.1.0 +version: 0.3.2.0 synopsis: Clipboard Manager description: See category: Clipboard @@ -28,6 +28,7 @@ library exposed-modules: Helic + Helic.App Helic.Cli Helic.Cli.Options Helic.Config.File diff --git a/lib/Helic/App.hs b/lib/Helic/App.hs new file mode 100644 --- /dev/null +++ b/lib/Helic/App.hs @@ -0,0 +1,116 @@ +module Helic.App where + +import Polysemy.Chronos (ChronosTime) +import qualified Polysemy.Conc as Conc +import Polysemy.Conc ( + Critical, + Interrupt, + interpretAtomic, + interpretEventsChan, + interpretSync, + withAsync_, + ) +import Polysemy.Http (Manager) +import Polysemy.Http.Interpreter.Manager (interpretManager) +import Polysemy.Log ( + Log, + Logger, + ) +import Polysemy.Time (GhcTime) + +import Helic.Data.Config (Config (Config)) +import Helic.Data.Event (Event) +import Helic.Data.ListConfig (ListConfig) +import Helic.Data.LoadConfig (LoadConfig (LoadConfig)) +import Helic.Data.NetConfig (NetConfig) +import Helic.Data.XClipboardEvent (XClipboardEvent) +import Helic.Data.YankConfig (YankConfig) +import qualified Helic.Effect.Client as Client +import Helic.Effect.Client (Client) +import qualified Helic.Effect.History as History +import Helic.Interpreter.AgentNet (interpretAgentNet) +import Helic.Interpreter.AgentTmux (interpretAgentTmux) +import Helic.Interpreter.AgentX (interpretAgentX) +import Helic.Interpreter.Client (interpretClientNet) +import Helic.Interpreter.History (interpretHistory) +import Helic.Interpreter.InstanceName (interpretInstanceName) +import Helic.Interpreter.XClipboard (interpretXClipboardGtk, listenXClipboard) +import Helic.List (list) +import Helic.Net.Api (serve) +import Helic.Yank (yank) + +type IOStack = + [ + Error Text, + Logger, + Interrupt, + Critical, + ChronosTime, + GhcTime, + Race, + Async, + Resource, + Embed IO, + Final IO + ] + +type AppStack = + Log : IOStack + +listenApp :: + Config -> + Sem AppStack () +listenApp (Config name tmux net maxHistory _) = + runReader (fromMaybe def tmux) $ + runReader (fromMaybe def net) $ + interpretEventsChan @XClipboardEvent $ + interpretEventsChan @Event $ + interpretAtomic mempty $ + interpretInstanceName name $ + interpretManager $ + listenXClipboard $ + interpretXClipboardGtk $ + interpretAgentX $ + interpretAgentNet $ + interpretAgentTmux $ + interpretHistory maxHistory $ + interpretSync $ + withAsync_ serve $ + Conc.subscribeLoop History.receive + +yankApp :: + Config -> + YankConfig -> + Sem AppStack () +yankApp (Config name _ net _ _) yankConfig = + interpretManager $ + interpretInstanceName name $ + runReader (fromMaybe def net) $ + interpretClientNet $ + yank yankConfig + +runClient :: + Members [Log, Error Text, Race, Embed IO] r => + Maybe NetConfig -> + InterpretersFor [Client, Reader NetConfig, Manager] r +runClient net = + interpretManager . + runReader (fromMaybe def net) . + interpretClientNet + +listApp :: + Config -> + ListConfig -> + Sem AppStack () +listApp (Config _ _ net _ _) listConfig = + runReader listConfig $ + runClient net $ + list + +loadApp :: + Config -> + LoadConfig -> + Sem AppStack () +loadApp (Config _ _ net _ _) (LoadConfig event) = + runClient net $ + (void . fromEither =<< Client.load event) diff --git a/lib/Helic/Cli.hs b/lib/Helic/Cli.hs --- a/lib/Helic/Cli.hs +++ b/lib/Helic/Cli.hs @@ -4,148 +4,68 @@ module Helic.Cli where import Options.Applicative (customExecParser, fullDesc, header, helper, info, prefs, showHelpOnEmpty, showHelpOnError) -import Polysemy.Chronos (ChronosTime, interpretTimeChronos) +import Polysemy.Chronos (interpretTimeChronos) import qualified Polysemy.Conc as Conc import Polysemy.Conc ( - Critical, - Interrupt, - interpretAtomic, interpretCritical, - interpretEventsChan, interpretInterrupt, interpretRace, - interpretSync, - withAsync_, ) import Polysemy.Error (errorToIOFinal) -import Polysemy.Http (Manager) -import Polysemy.Http.Interpreter.Manager (interpretManager) -import qualified Polysemy.Log as Log -import Polysemy.Log (Log, Severity (Info, Trace), interpretLogStdoutLevelConc) -import Polysemy.Time (MilliSeconds (MilliSeconds)) +import Polysemy.Log ( + 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) +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 Helic.Data.Config (Config (Config)) -import Helic.Data.Event (Event) -import Helic.Data.ListConfig (ListConfig) -import Helic.Data.LoadConfig (LoadConfig (LoadConfig)) -import Helic.Data.NetConfig (NetConfig) -import Helic.Data.XClipboardEvent (XClipboardEvent) +import qualified Helic.Data.Config as Config +import Helic.Data.Config (Config) import Helic.Data.YankConfig (YankConfig (YankConfig)) -import qualified Helic.Effect.Client as Client -import Helic.Effect.Client (Client) -import qualified Helic.Effect.History as History -import Helic.Interpreter.AgentNet (interpretAgentNet) -import Helic.Interpreter.AgentTmux (interpretAgentTmux) -import Helic.Interpreter.AgentX (interpretAgentX) -import Helic.Interpreter.Client (interpretClientNet) -import Helic.Interpreter.History (interpretHistory) -import Helic.Interpreter.InstanceName (interpretInstanceName) -import Helic.Interpreter.XClipboard (interpretXClipboardGtk, listenXClipboard) -import Helic.List (list) -import Helic.Net.Api (serve) -import Helic.Yank (yank) logError :: - Members [Log, Final IO] r => + Members [Logger, GhcTime, Final IO] r => Sem (Error Text : r) () -> Sem r () -logError sem = - errorToIOFinal sem >>= \case - Right () -> unit - Left err -> Log.error err +logError = + traverseLeft DataLog.error <=< errorToIOFinal -type IOStack = - [ - Error Text, - Interrupt, - Critical, - Log, - ChronosTime, - Race, - Async, - Resource, - Embed IO, - Final IO - ] +interpretLog :: + Maybe Bool -> + InterpreterFor Log IOStack +interpretLog (fromMaybe False -> verbose) = + setLogLevel (if verbose then Just Trace else Just Info) . interpretLogDataLog runIO :: - Bool -> Sem IOStack () -> IO () -runIO verbose = +runIO = runFinal . embedToFinal . resourceToIOFinal . asyncToIOFinal . interpretRace . + interpretTimeGhc . interpretTimeChronos . - interpretLogStdoutLevelConc (if verbose then (Just Trace) else Just Info) . interpretCritical . interpretInterrupt . + interpretDataLogStdoutWith formatLogEntry . + interceptDataLogConc @(LogEntry LogMessage) 64 . logError -listenApp :: - Config -> - Sem IOStack () -listenApp (Config name tmux net maxHistory) = - runReader (fromMaybe def tmux) $ - runReader (fromMaybe def net) $ - interpretEventsChan @XClipboardEvent $ - interpretEventsChan @Event $ - interpretAtomic mempty $ - interpretInstanceName name $ - interpretManager $ - listenXClipboard $ - interpretXClipboardGtk $ - interpretAgentX $ - interpretAgentNet $ - interpretAgentTmux $ - interpretHistory maxHistory $ - interpretSync $ - withAsync_ serve $ - Conc.subscribeLoop History.receive - -yankApp :: - Config -> - YankConfig -> - Sem IOStack () -yankApp (Config name _ net _) yankConfig = - interpretManager $ - interpretInstanceName name $ - runReader (fromMaybe def net) $ - interpretClientNet $ - yank yankConfig - -runClient :: - Members [Log, Error Text, Race, Embed IO] r => - Maybe NetConfig -> - InterpretersFor [Client, Reader NetConfig, Manager] r -runClient net = - interpretManager . - runReader (fromMaybe def net) . - interpretClientNet - -listApp :: - Config -> - ListConfig -> - Sem IOStack () -listApp (Config _ _ net _) listConfig = - runReader listConfig $ - runClient net $ - list - -loadApp :: - Config -> - LoadConfig -> - Sem IOStack () -loadApp (Config _ _ net _) (LoadConfig event) = - runClient net $ - (void . fromEither =<< Client.load event) - -runCommand :: Config -> Command -> Sem IOStack () +runCommand :: Config -> Command -> Sem AppStack () runCommand config = \case Listen -> listenApp config @@ -163,10 +83,11 @@ _ -> Listen withCliOptions :: Conf -> Maybe Command -> IO () -withCliOptions (Conf verbose file) cmd = - runIO verbose do - config <- findFileConfig file - runCommand config =<< maybe defaultCommand pure cmd +withCliOptions (Conf cliVerbose file) cmd = + runIO do + config <- interpretLog cliVerbose (findFileConfig file) + cmd' <- maybe defaultCommand pure cmd + interpretLog (cliVerbose <|> Config.verbose config) (runCommand config cmd') app :: IO () app = do diff --git a/lib/Helic/Cli/Options.hs b/lib/Helic/Cli/Options.hs --- a/lib/Helic/Cli/Options.hs +++ b/lib/Helic/Cli/Options.hs @@ -30,7 +30,7 @@ data Conf = Conf { - verbose :: Bool, + verbose :: Maybe Bool, configFile :: Maybe (Path Abs File) } deriving stock (Eq, Show) @@ -52,7 +52,7 @@ confParser :: Parser Conf confParser = do - verbose <- switch (long "verbose") + verbose <- optional (switch (long "verbose")) configFile <- optional (option filePathOption (long "config-file")) pure (Conf verbose configFile) diff --git a/lib/Helic/Data/Config.hs b/lib/Helic/Data/Config.hs --- a/lib/Helic/Data/Config.hs +++ b/lib/Helic/Data/Config.hs @@ -10,7 +10,8 @@ name :: Maybe Text, tmux :: Maybe TmuxConfig, net :: Maybe NetConfig, - maxHistory :: Maybe Int + maxHistory :: Maybe Int, + verbose :: Maybe Bool } deriving stock (Eq, Show, Generic) deriving anyclass (Default) diff --git a/lib/Helic/Interpreter/History.hs b/lib/Helic/Interpreter/History.hs --- a/lib/Helic/Interpreter/History.hs +++ b/lib/Helic/Interpreter/History.hs @@ -134,10 +134,11 @@ Sem r (Maybe Event) loadEvent index = do now <- Time.now - atomicState' \ s -> - case (s !? (length s - index - 1)) of + atomicState' \ s -> do + let rindex = length s - index - 1 + case (s !? rindex) of Just event -> - (Seq.deleteAt index s |> event { time = now }, Just event) + (Seq.deleteAt rindex s |> event { time = now }, Just event) Nothing -> (s, Nothing) diff --git a/lib/Helic/List.hs b/lib/Helic/List.hs --- a/lib/Helic/List.hs +++ b/lib/Helic/List.hs @@ -39,8 +39,8 @@ formatTime (Datetime _ tod) = toLazyText (builder_HMS (SubsecondPrecisionFixed 0) (Just ':') tod) -format :: Int -> [Event] -> String -format width events = +format :: Int -> NonEmpty Event -> String +format width (toList -> events) = tableString cols unicodeRoundS titles (row <$> zip [lastIndex,lastIndex-1..0] events) where lastIndex = @@ -69,7 +69,7 @@ events = maybe id dropper limit (toList history) width <- fromMaybe 80 . fmap TerminalSize.width <$> embed TerminalSize.size - pure (format width events) + pure (maybe "No events yet!" (format width) (nonEmpty events)) -- |Print a number of events to stdout. list :: diff --git a/lib/Helic/Net/Api.hs b/lib/Helic/Net/Api.hs --- a/lib/Helic/Net/Api.hs +++ b/lib/Helic/Net/Api.hs @@ -3,7 +3,7 @@ import Polysemy.Conc (Interrupt, Sync) import Polysemy.Log (Log) -import Servant (Get, JSON, NoContent (NoContent), Post, PostCreated, ReqBody, type (:<|>) ((:<|>)), type (:>)) +import Servant (Get, JSON, NoContent (NoContent), PostCreated, PutAccepted, ReqBody, type (:<|>) ((:<|>)), type (:>)) import Servant.Server (Context (EmptyContext), ServerT) import Helic.Data.Event (Event) @@ -20,7 +20,7 @@ :<|> ReqBody '[JSON] Event :> PostCreated '[JSON] NoContent :<|> - ReqBody '[JSON] Int :> Post '[JSON] (Maybe Event) + ReqBody '[JSON] Int :> PutAccepted '[JSON] (Maybe Event) ) -- |The server implementation. diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -24,6 +24,22 @@ |`hel list`|Print the event history.| |`hel load`|Load an older event to the clipboard, given its index into the history.| +The `list` command will print a table like this: + +``` +╭───┬──────────┬───────┬──────────┬──────────────────────────╮ +│ # │ Instance │ Agent │ Time │ Content │ +╞═══╪══════════╪═══════╪══════════╪══════════════════════════╡ +│ 2 │ test │ nvim │ 12:00:00 │ single line │ +├───┼──────────┼───────┼──────────┼──────────────────────────┤ +│ 1 │ test │ nvim │ 12:00:00 │ single line with newline │ +├───┼──────────┼───────┼──────────┼──────────────────────────┤ +│ 0 │ test │ nvim │ 12:00:00 │ three lines 1 [3 lines] │ +╰───┴──────────┴───────┴──────────┴──────────────────────────╯ +``` + +The index in the first column, with 0 being the latest event, can be used with `hel load`. + # Installing and Running Helic ## Nix @@ -107,6 +123,7 @@ ```yaml name: myhost maxHistory: 1000 +verbose: true net: port: 10001 hosts: @@ -126,6 +143,7 @@ enable = true; name = "myhost"; maxHistory = 1000; + verbose = true; net = { port = 10001; hosts = ["remote1:1000" "remote2:2000"]; @@ -145,6 +163,7 @@ |---|---|---| |`name`|Host name|An identifier for the host, used for filtering duplicates.| |`maxHistory`|100|The number of yanks that should be kept.| +|`verbose`||Increase the log level.| |`net.port`|`9500`|The HTTP port the daemon listens to for both remote sync and `hel yank`.| |`net.hosts`|`[]`|The addresses (with port) of the hosts to which this instance should broadcast yank events.| |`net.timeout`|`300`|The timeout in milliseconds for requests to remote hosts.| diff --git a/test/Helic/Test/ConfigFileTest.hs b/test/Helic/Test/ConfigFileTest.hs --- a/test/Helic/Test/ConfigFileTest.hs +++ b/test/Helic/Test/ConfigFileTest.hs @@ -12,7 +12,7 @@ target :: Config target = - Config (Just "name") (Just tmux) (Just net) (Just 1000) + Config (Just "name") (Just tmux) (Just net) (Just 1000) (Just False) where tmux = TmuxConfig (Just True) (Just [absfile|/bin/tmux|]) diff --git a/test/Helic/Test/LoadTest.hs b/test/Helic/Test/LoadTest.hs --- a/test/Helic/Test/LoadTest.hs +++ b/test/Helic/Test/LoadTest.hs @@ -37,3 +37,4 @@ ev5 <- event 6 assertJust ev5 =<< History.load 4 assertEq Nothing =<< History.load 11 + assertEq (show <$> ([1..5] ++ [7..10] ++ [6 :: Int])) =<< fmap Event.content <$> History.get