glirc 2.3 → 2.4
raw patch · 10 files changed
+265/−130 lines, 10 filesdep +gitrevdep −profunctors
Dependencies added: gitrev
Dependencies removed: profunctors
Files
- ChangeLog.md +7/−0
- README.md +5/−3
- glirc.cabal +3/−2
- src/Client/CommandArguments.hs +15/−1
- src/Client/Commands.hs +133/−44
- src/Client/Configuration.hs +46/−11
- src/Client/EventLoop.hs +11/−51
- src/Client/State.hs +1/−1
- src/LensUtils.hs +13/−17
- src/StrictUnit.hs +31/−0
ChangeLog.md view
@@ -1,5 +1,12 @@ # Revision history for glirc2 +## 2.4++* Support XDG configuration directory, e.g. `~/.config/glirc/config`+* Add more window names. Shift selects second set of names.+* Add `/channel` and `/say`+* Improve `/focus` tab completion+ ## 2.3 * Add commands `/znc`
README.md view
@@ -138,10 +138,11 @@ * `/focus <server> <channel>` - Change focus to channel window * `/clear` - Clear contents of current window * `/ignore <nick>` - Toggle ignore of a user+* `/channel <channel>` - Change focus to channel on current network (alias: `/c`) Channel membership -* `/join <channel>` - Join a channel+* `/join <channel>` - Join a channel (alias: `/j`) * `/part` - Part from current channel Chat commands@@ -149,7 +150,8 @@ * `/msg <target> <msg>` - Send a message on the current server to target * `/notice <target> <msg>` - Send a notice message on the current server to target * `/ctcp <target> <command> <args>` - Send a ctcp command on the current server to target-* `/me` - Send action message to channel+* `/me <msg>` - Send action message to channel+* `/say <msg>` - Send normal message to channel Channel management @@ -198,7 +200,7 @@ * `^N` next channel * `^P` previous channel-* `M-#` jump to window - 1234567890qwertyuiop+* `M-#` jump to window - 1234567890qwertyuiop!@#$%^&*()QWERTYUIOP * `M-A` jump to activity * `^A` beginning of line * `^E` end of line
glirc.cabal view
@@ -1,5 +1,5 @@ name: glirc-version: 2.3+version: 2.4 synopsis: Console IRC client description: Console IRC client license: ISC@@ -57,6 +57,7 @@ Irc.RawIrcMsg Irc.UserInfo LensUtils+ StrictUnit Paths_glirc -- other-extensions:@@ -71,11 +72,11 @@ deepseq >=1.4 && <1.5, directory >=1.2.6 && <1.3, filepath >=1.4.1 && <1.5,+ gitrev >=1.2 && <1.3, hashable >=1.2.4 && <1.3, lens >=4.14 && <4.15, memory >=0.13 && <0.14, network >=2.6.2 && <2.7,- profunctors >=5.2 && <5.3, split >=0.2 && <0.3, stm >=2.4 && <2.5, text >=1.2.2 && <1.3,
src/Client/CommandArguments.hs view
@@ -26,6 +26,7 @@ import Data.Foldable import qualified Data.Text as Text import Data.Version+import Development.GitRev (gitHash, gitDirty) import System.Console.GetOpt import System.Environment import System.Exit@@ -89,7 +90,20 @@ versionTxt :: String versionTxt = unlines- [ "glirc-" ++ showVersion version+ [ "glirc-" ++ showVersion version ++ gitHashTxt ++ gitDirtyTxt , "Copyright 2016 Eric Mertens" ] +-- | Returns @"-SOMEHASH"@ when in a git repository, @""@ otherwise.+gitHashTxt :: String+gitHashTxt+ | hashTxt == "UNKNOWN" = ""+ | otherwise = '-':hashTxt+ where+ hashTxt = $gitHash++-- | Returns @"-dirty"@ when in a dirty git repository, @""@ otherwise.+gitDirtyTxt :: String+gitDirtyTxt+ | $gitDirty = "-dirty"+ | otherwise = ""
src/Client/Commands.hs view
@@ -13,8 +13,8 @@ module Client.Commands ( CommandResult(..)- , executeCommand- , nickTabCompletion+ , execute+ , tabCompletion ) where import Client.ConnectionState@@ -60,20 +60,62 @@ -- The tab-completion logic is extended with a bool -- indicating that tab completion should be reversed data Command- = ClientCommand ClientCommand (Bool -> ClientCommand)- | NetworkCommand NetworkCommand (Bool -> NetworkCommand)- | ChannelCommand ChannelCommand (Bool -> ChannelCommand)-+ = ClientCommand ClientCommand (Bool -> ClientCommand) -- ^ no requirements+ | NetworkCommand NetworkCommand (Bool -> NetworkCommand) -- ^ requires an active network+ | ChatCommand ChannelCommand (Bool -> ChannelCommand) -- ^ requires an active chat window+ | ChannelCommand ChannelCommand (Bool -> ChannelCommand) -- ^ requires an active channel window +-- | Resume the client without further state changes commandContinue :: Monad m => ClientState -> m CommandResult commandContinue = return . CommandContinue +-- | Consider the text entry successful and resume the client commandSuccess :: Monad m => ClientState -> m CommandResult-commandSuccess = return . CommandContinue . consumeInput+commandSuccess = commandContinue . consumeInput +-- | Consider the text entry a failure and resume the client commandFailure :: Monad m => ClientState -> m CommandResult-commandFailure = return . CommandContinue . set clientBell True+commandFailure = commandContinue . set clientBell True +-- | Interpret whatever text is in the textbox. Leading @/@ indicates a+-- command. Otherwise if a channel or user query is focused a chat message+-- will be sent.+execute :: ClientState -> IO CommandResult+execute st =+ case clientInput st of+ [] -> commandFailure st+ '/':command -> executeCommand Nothing command st+ msg -> executeChat msg st++-- | Respond to the TAB key being pressed. This can dispatch to a command+-- specific completion mode when relevant. Otherwise this will complete+-- input based on the users of the channel related to the current buffer.+tabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO CommandResult+tabCompletion isReversed st =+ case clientInput st of+ '/':command -> executeCommand (Just isReversed) command st+ _ -> commandContinue (nickTabCompletion isReversed st)++-- | Treat the current text input as a chat message and send it.+executeChat :: String -> ClientState -> IO CommandResult+executeChat msg st =+ case view clientFocus st of+ ChannelFocus network channel+ | Just cs <- preview (clientConnection network) st ->+ do now <- getZonedTime+ let msgTxt = Text.pack msg+ ircMsg = rawIrcMsg "PRIVMSG" [idText channel, msgTxt]+ myNick = UserInfo (view csNick cs) Nothing Nothing+ entry = ClientMessage+ { _msgTime = now+ , _msgNetwork = network+ , _msgBody = IrcBody (Privmsg myNick channel msgTxt)+ }+ sendMsg cs ircMsg+ commandSuccess $ recordChannelMessage network channel entry st++ _ -> commandFailure st+ splitWord :: String -> (String, String) splitWord str = (w, drop 1 rest) where@@ -115,51 +157,65 @@ maybe exec tab tabCompleteReversed network cs channelId st rest + Just (ChatCommand exec tab)+ | ChannelFocus network channelId <- view clientFocus st+ , Just cs <- preview (clientConnection network) st ->+ maybe exec tab tabCompleteReversed+ network cs channelId st rest+ _ -> case tabCompleteReversed of Nothing -> commandFailure st Just isReversed -> commandContinue (nickTabCompletion isReversed st) +-- Expands each alias to have its own copy of the command callbacks+expandAliases :: [([a],b)] -> [(a,b)]+expandAliases xs = [ (a,b) | (as,b) <- xs, a <- as ]+ commands :: HashMap Text Command commands = HashMap.fromList- [ ("connect" , ClientCommand cmdConnect noClientTab)- , ("exit" , ClientCommand cmdExit noClientTab)- , ("focus" , ClientCommand cmdFocus simpleClientTab)- , ("clear" , ClientCommand cmdClear noClientTab)- , ("reconnect" , ClientCommand cmdReconnect noClientTab)- , ("ignore" , ClientCommand cmdIgnore simpleClientTab)+ $ expandAliases+ [ (["connect" ], ClientCommand cmdConnect noClientTab)+ , (["exit" ], ClientCommand cmdExit noClientTab)+ , (["focus" ], ClientCommand cmdFocus tabFocus)+ , (["clear" ], ClientCommand cmdClear noClientTab)+ , (["reconnect" ], ClientCommand cmdReconnect noClientTab)+ , (["ignore" ], ClientCommand cmdIgnore simpleClientTab) - , ("quote" , NetworkCommand cmdQuote simpleNetworkTab)- , ("join" , NetworkCommand cmdJoin simpleNetworkTab)- , ("mode" , NetworkCommand cmdMode tabMode)- , ("msg" , NetworkCommand cmdMsg simpleNetworkTab)- , ("notice" , NetworkCommand cmdNotice simpleNetworkTab)- , ("ctcp" , NetworkCommand cmdCtcp simpleNetworkTab)- , ("nick" , NetworkCommand cmdNick simpleNetworkTab)- , ("quit" , NetworkCommand cmdQuit simpleNetworkTab)- , ("disconnect", NetworkCommand cmdDisconnect noNetworkTab)- , ("who" , NetworkCommand cmdWho simpleNetworkTab)- , ("whois" , NetworkCommand cmdWhois simpleNetworkTab)- , ("whowas" , NetworkCommand cmdWhowas simpleNetworkTab)- , ("ison" , NetworkCommand cmdIson simpleNetworkTab)- , ("userhost" , NetworkCommand cmdUserhost simpleNetworkTab)- , ("away" , NetworkCommand cmdAway simpleNetworkTab)- , ("links" , NetworkCommand cmdLinks simpleNetworkTab)- , ("time" , NetworkCommand cmdTime simpleNetworkTab)- , ("stats" , NetworkCommand cmdStats simpleNetworkTab)- , ("znc" , NetworkCommand cmdZnc simpleNetworkTab)- , ("znc-playback", NetworkCommand cmdZncPlayback noNetworkTab)+ , (["quote" ], NetworkCommand cmdQuote simpleNetworkTab)+ , (["j","join" ], NetworkCommand cmdJoin simpleNetworkTab)+ , (["c","channel"], NetworkCommand cmdChannel simpleNetworkTab)+ , (["mode" ], NetworkCommand cmdMode tabMode)+ , (["msg" ], NetworkCommand cmdMsg simpleNetworkTab)+ , (["notice" ], NetworkCommand cmdNotice simpleNetworkTab)+ , (["ctcp" ], NetworkCommand cmdCtcp simpleNetworkTab)+ , (["nick" ], NetworkCommand cmdNick simpleNetworkTab)+ , (["quit" ], NetworkCommand cmdQuit simpleNetworkTab)+ , (["disconnect"], NetworkCommand cmdDisconnect noNetworkTab)+ , (["who" ], NetworkCommand cmdWho simpleNetworkTab)+ , (["whois" ], NetworkCommand cmdWhois simpleNetworkTab)+ , (["whowas" ], NetworkCommand cmdWhowas simpleNetworkTab)+ , (["ison" ], NetworkCommand cmdIson simpleNetworkTab)+ , (["userhost" ], NetworkCommand cmdUserhost simpleNetworkTab)+ , (["away" ], NetworkCommand cmdAway simpleNetworkTab)+ , (["links" ], NetworkCommand cmdLinks simpleNetworkTab)+ , (["time" ], NetworkCommand cmdTime simpleNetworkTab)+ , (["stats" ], NetworkCommand cmdStats simpleNetworkTab)+ , (["znc" ], NetworkCommand cmdZnc simpleNetworkTab)+ , (["znc-playback"], NetworkCommand cmdZncPlayback noNetworkTab) - , ("invite" , ChannelCommand cmdInvite simpleChannelTab)- , ("topic" , ChannelCommand cmdTopic tabTopic )- , ("kick" , ChannelCommand cmdKick simpleChannelTab)- , ("kickban" , ChannelCommand cmdKickBan simpleChannelTab)- , ("remove" , ChannelCommand cmdRemove simpleChannelTab)- , ("me" , ChannelCommand cmdMe simpleChannelTab)- , ("part" , ChannelCommand cmdPart simpleChannelTab)+ , (["invite" ], ChannelCommand cmdInvite simpleChannelTab)+ , (["topic" ], ChannelCommand cmdTopic tabTopic )+ , (["kick" ], ChannelCommand cmdKick simpleChannelTab)+ , (["kickban" ], ChannelCommand cmdKickBan simpleChannelTab)+ , (["remove" ], ChannelCommand cmdRemove simpleChannelTab)+ , (["part" ], ChannelCommand cmdPart simpleChannelTab) - , ("users" , ChannelCommand cmdUsers noChannelTab)- , ("channelinfo", ChannelCommand cmdChannelInfo noChannelTab)- , ("masks" , ChannelCommand cmdMasks noChannelTab)+ , (["users" ], ChannelCommand cmdUsers noChannelTab)+ , (["channelinfo"], ChannelCommand cmdChannelInfo noChannelTab)+ , (["masks" ], ChannelCommand cmdMasks noChannelTab)++ , (["me" ], ChatCommand cmdMe simpleChannelTab)+ , (["say" ], ChatCommand cmdSay simpleChannelTab) ] noClientTab :: Bool -> ClientCommand@@ -339,6 +395,23 @@ _ -> commandFailure st +-- | When tab completing the first parameter of the focus command+-- the current networks are used.+tabFocus :: Bool -> ClientCommand+tabFocus isReversed st _+ = commandContinue+ $ fromMaybe st+ $ clientTextBox (wordComplete id isReversed completions) st+ where+ networks = map mkId $ HashMap.keys $ view clientNetworkMap st+ textBox = view clientTextBox st+ params = words $ take (view EditBox.pos textBox)+ (view EditBox.content textBox)++ completions+ | length params == 2 = networks+ | otherwise = currentCompletionList st+ cmdWhois :: NetworkCommand cmdWhois _ cs st rest = do sendMsg cs (ircWhois (Text.pack <$> words rest))@@ -446,6 +519,11 @@ sendMsg cs (ircPart channelId (Text.pack msg)) commandSuccess st +-- | This command is equivalent to chatting without a command. The primary use+-- at the moment is to be able to send a leading @/@ to chat easily.+cmdSay :: ChannelCommand+cmdSay _network _cs _channelId st rest = executeChat rest st+ cmdInvite :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult cmdInvite _ cs channelId st rest = case words rest of@@ -562,6 +640,17 @@ [channel] -> doJoin channel Nothing [channel,key] -> doJoin channel (Just key) _ -> commandFailure st+++-- | @/channel@ command. Takes the name of a channel and switches+-- focus to that channel on the current network.+cmdChannel :: NetworkCommand+cmdChannel network _ st rest =+ case mkId . Text.pack <$> words rest of+ [ channelId ] ->+ commandSuccess+ $ changeFocus (ChannelFocus network channelId) st+ _ -> commandFailure st cmdQuit :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult
src/Client/Configuration.hs view
@@ -63,30 +63,65 @@ instance Exception ConfigurationFailure -getConfigPath :: IO FilePath-getConfigPath =+-- | Uses 'getAppUserDataDirectory' to find @.glirc/config@+getOldConfigPath :: IO FilePath+getOldConfigPath = do dir <- getAppUserDataDirectory "glirc" return (dir </> "config") +-- | Uses 'getXdgDirectory' 'XdgConfig' to find @.config/glirc/config@+getNewConfigPath :: IO FilePath+getNewConfigPath =+ do dir <- getXdgDirectory XdgConfig "glirc"+ return (dir </> "config")+ -- | Empty configuration file used when no path is specified -- and the configuration file is missing. emptyConfigFile :: Text emptyConfigFile = "{}\n" +-- | Attempt to read a file using the given handler when+-- a file does not exist. On failure a 'ConfigurationReadFailed'+-- exception is throw.+readFileCatchNotFound ::+ FilePath {- ^ file to read -} ->+ (IOError -> IO Text) {- ^ error handler for not found case -} ->+ IO Text+readFileCatchNotFound path onNotFound =+ do res <- try (Text.readFile path)+ case res of+ Left e | isDoesNotExistError e -> onNotFound e+ | otherwise -> throwIO (ConfigurationReadFailed (show e))+ Right txt -> return txt++-- | Either read a configuration file from one of the default+-- locations, in which case no configuration found is equivalent+-- to an empty configuration, or from the specified file where+-- no configuration found is an error.+readConfigurationFile ::+ Maybe FilePath {- ^ just file or use default search paths -} ->+ IO Text+readConfigurationFile mbPath =+ case mbPath of++ Just path ->+ readFileCatchNotFound path $ \e ->+ throwIO (ConfigurationReadFailed (show e))++ Nothing ->+ do newPath <- getNewConfigPath+ readFileCatchNotFound newPath $ \_ ->+ do oldPath <- getOldConfigPath+ readFileCatchNotFound oldPath $ \_ ->+ return emptyConfigFile++ -- | Load the configuration file defaulting to @~/.glirc/config@. loadConfiguration :: Maybe FilePath {- ^ path to configuration file -} -> IO (Either ConfigurationFailure Configuration) loadConfiguration mbPath = try $- do path <- maybe getConfigPath return mbPath- fileRes <- try (Text.readFile path)- file <- case fileRes of- Right file -> return file- Left e | isNothing mbPath- , isDoesNotExistError e -> return emptyConfigFile- | otherwise ->- throwIO (ConfigurationReadFailed (show e))-+ do file <- readConfigurationFile mbPath def <- loadDefaultServerSettings rawcfg <-
src/Client/EventLoop.hs view
@@ -34,13 +34,10 @@ import qualified Data.Map as Map import Data.Maybe import Data.Ord-import qualified Data.Text as Text import Data.Time import Graphics.Vty-import Irc.Identifier import Irc.Message import Irc.RawIrcMsg-import Irc.UserInfo -- | Sum of the three possible event types the event loop handles@@ -240,17 +237,25 @@ KEnd -> changeInput Edit.end KUp -> changeInput $ \ed -> fromMaybe ed $ Edit.earlier ed KDown -> changeInput $ \ed -> fromMaybe ed $ Edit.later ed- KEnter -> execute st KPageUp -> eventLoop (pageUp st) KPageDown -> eventLoop (pageDown st)- KBackTab -> tabCompletion True st- KChar '\t' -> tabCompletion False st++ KEnter -> doCommandResult =<< execute st+ KBackTab -> doCommandResult =<< tabCompletion True st+ KChar '\t' -> doCommandResult =<< tabCompletion False st+ KChar c -> changeInput (Edit.insert c) KFun 2 -> eventLoop (over clientDetailView not st) _ -> eventLoop st _ -> eventLoop st -- unsupported modifier +doCommandResult :: CommandResult -> IO ()+doCommandResult res =+ case res of+ CommandQuit -> return ()+ CommandContinue st -> eventLoop st+ -- | Scroll the current buffer to show older messages pageUp :: ClientState -> ClientState pageUp st = over clientScroll (+ scrollAmount st) st@@ -287,51 +292,6 @@ windows = view clientWindows st (focus,_) = Map.elemAt i windows --- | Respond to the TAB key being pressed. This can dispatch to a command--- specific completion mode when relevant. Otherwise this will complete--- input based on the users of the channel related to the current buffer.-tabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO ()-tabCompletion isReversed st =- case clientInput st of- '/':command -> do res <- executeCommand (Just isReversed) command st- case res of- CommandQuit -> return ()- CommandContinue st' -> eventLoop st'- _ -> eventLoop (nickTabCompletion isReversed st)---- | Interpret whatever text is in the textbox. Leading @/@ indicates a--- command. Otherwise if a channel or user query is focused a chat message--- will be sent.-execute :: ClientState -> IO ()-execute st =- case clientInput st of- [] -> eventLoop (set clientBell True st)- '/':command -> do res <- executeCommand Nothing command st- case res of- CommandQuit -> return ()- CommandContinue st' -> eventLoop st'- msg -> executeChat msg st---- | Treat the current text input as a chat message and send it.-executeChat :: String -> ClientState -> IO ()-executeChat msg st =- case view clientFocus st of- ChannelFocus network channel- | Just cs <- preview (clientConnection network) st ->- do now <- getZonedTime- let msgTxt = Text.pack msg- ircMsg = rawIrcMsg "PRIVMSG" [idText channel, msgTxt]- myNick = UserInfo (view csNick cs) Nothing Nothing- entry = ClientMessage- { _msgTime = now- , _msgNetwork = network- , _msgBody = IrcBody (Privmsg myNick channel msgTxt)- }- sendMsg cs ircMsg- eventLoop $ recordChannelMessage network channel entry- $ consumeInput st-- _ -> eventLoop (set clientBell True st) -- | Respond to a timer event. doTimerEvent ::
src/Client/State.hs view
@@ -443,7 +443,7 @@ . set clientSubfocus focus windowNames :: [Char]-windowNames = "1234567890qwertyuiop"+windowNames = "1234567890qwertyuiop!@#$%^&*()QWERTYUIOP" clientMatcher :: ClientState -> Text -> Bool clientMatcher st =
src/LensUtils.hs view
@@ -9,8 +9,9 @@ -} module LensUtils- ( Id'- , overStrict+ (+ -- * Strict update operations+ overStrict , setStrict -- * time lenses@@ -19,26 +20,17 @@ ) where import Control.Lens-import Control.Applicative-import Data.Profunctor.Unsafe import Data.Time--newtype Id' a = Id' { runId' :: a }---- | Strict function composition-instance Functor Id' where- fmap = liftA---- | Strict function application-instance Applicative Id' where- pure = Id'- Id' f <*> Id' x = Id' (f $! x)+import StrictUnit -- | Modify the target of a 'Setter' with a function. The result -- is strict in the results of applying the function. Strict version -- of 'over'-overStrict :: LensLike Id' s t a b -> (a -> b) -> s -> t-overStrict l f = runId' #. l (Id' #. f)+overStrict :: LensLike ((,) StrictUnit) s t a b -> (a -> b) -> s -> t+overStrict l f = run . l (nur . f)+ where+ nur y = (y `seq` StrictUnit, y)+ run (StrictUnit,y) = y {-# INLINE overStrict #-} -- | Set a value strictly in the set value. Strict version of 'set'.@@ -46,8 +38,12 @@ setStrict l x = set l $! x {-# INLINE setStrict #-} +-- | 'Lens' to the 'LocalTime' component of a 'ZonedTime' zonedTimeLocalTime :: Lens' ZonedTime LocalTime zonedTimeLocalTime f (ZonedTime t z) = f t <&> \t' -> ZonedTime t' z+{-# INLINE zonedTimeLocalTime #-} +-- | 'Lens' to the 'TimeOfDay component of a 'LocalTime'. localTimeTimeOfDay :: Lens' LocalTime TimeOfDay localTimeTimeOfDay f (LocalTime d t) = LocalTime d <$> f t+{-# INLINE localTimeTimeOfDay #-}
+ src/StrictUnit.hs view
@@ -0,0 +1,31 @@+{-|+Module : StrictUnit+Description : Strict unit type+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides a unit type where the 'Monoid' and 'Semigroup'+instances are strict in their append operations. This is a helper+module for "LensUtils".++-}++module StrictUnit+ ( StrictUnit(..)+ ) where++import Data.Semigroup++-- | Unit data type with a strict 'Semigroup' and 'Monoid' instances.+data StrictUnit = StrictUnit++-- | '<>' is strict, 'stimes' is /O(1)/+instance Semigroup StrictUnit where+ (<>) = seq+ stimes = stimesIdempotent++-- | 'mappend' is strict+instance Monoid StrictUnit where+ mempty = StrictUnit+ mappend = (<>)