diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for glirc2 +## 2.19 + +* Smarter text box tracks "scroll" position independently from cursor +* Added `--full-version` flag +* Remove `regex-tdfa-text` dependency +* Added `bell-on-mention` client setting +* Added `ExportCApi` cabal flag to help with loading the client in GHCi + ## 2.18 * Add digraph support under `M-k` and `/digraphs` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -179,6 +179,7 @@ | `url-opener` | text | Command to execute with URL parameter for `/url` e.g. gnome-open on GNOME or open on macOS | | `ignores` | list of text | Initial list of nicknames to ignore | | `activity-bar` | yes or no | Initial setting for visibility of activity bar (default no) | +| `bell-on-mention` | yes or no | Sound terminal bell on transition from not mentioned to mentioned (default no) | | `macros` | list of macros | User-configurable client commands | Server Settings diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -6,35 +6,142 @@ Maintainer : emertens@gmail.com This is a default setup script except that it checks that all -transitive dependencies of this package use free licenses. +transitive dependencies of this package use free licenses and +generates a Build module detailing the versions of build tools +and transitive library dependencies. -} module Main (main) where -import Distribution.Simple -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.PackageIndex -import Distribution.InstalledPackageInfo -import Control.Monad +import Control.Monad (unless) +import Data.Char (isAlphaNum) +import Data.List (delete) +import Distribution.InstalledPackageInfo (InstalledPackageInfo, sourcePackageId, license) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription hiding (license) +import Distribution.Simple +import Distribution.Simple.BuildPaths (autogenModulesDir) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, installedPkgs) +import Distribution.Simple.PackageIndex (allPackages) +import Distribution.Simple.Setup (configVerbosity, fromFlag) +import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, rewriteFile) +import Distribution.Verbosity (Verbosity) +import System.FilePath ((), (<.>)) + +-- | Default Setup main extended to generate a Build module and to validate +-- the licenses of transitive dependencies. main :: IO () main = defaultMainWithHooks simpleUserHooks + { postConf = \args flags pkg lbi -> - do validateLicenses lbi + do let pkgs = allPackages (installedPkgs lbi) + validateLicenses pkgs + generateBuildModule (fromFlag (configVerbosity flags)) pkg lbi pkgs postConf simpleUserHooks args flags pkg lbi + + , sDistHook = \pkg mbLbi hooks flags -> + do let pkg' = forgetBuildModule pkg + sDistHook simpleUserHooks pkg' mbLbi hooks flags } -validateLicenses :: LocalBuildInfo -> IO () -validateLicenses lbi = - do let p pkg = license pkg `notElem` freeLicenses - badPkgs = filter p - $ allPackages - $ installedPkgs lbi +-- | Remove the Build module from the package description. This is needed +-- when building a source distribution tarball because the Build module +-- should be generated dynamically at configuration time. +forgetBuildModule :: + PackageDescription {- ^ package description with Build module -} -> + PackageDescription {- ^ package description without Build module -} +forgetBuildModule pkg = pkg + { library = forgetInLibrary <$> library pkg + , executables = forgetInExecutable <$> executables pkg + , benchmarks = forgetInBenchmark <$> benchmarks pkg + , testSuites = forgetInTestSuite <$> testSuites pkg + } + where + forget = delete (ModuleName.fromString (buildModuleName pkg)) + + forgetInBuildInfo x = x + { otherModules = forget (otherModules x) } + + forgetInLibrary x = x + { exposedModules = forget (exposedModules x) + , libBuildInfo = forgetInBuildInfo (libBuildInfo x) } + + forgetInTestSuite x = x + { testBuildInfo = forgetInBuildInfo (testBuildInfo x) } + + forgetInBenchmark x = x + { benchmarkBuildInfo = forgetInBuildInfo (benchmarkBuildInfo x) } + + forgetInExecutable x = x + { buildInfo = forgetInBuildInfo (buildInfo x) } + + +-- | Compute the name of the Build module for a given package +buildModuleName :: + PackageDescription {- ^ package description -} -> + String {- ^ module name -} +buildModuleName pkg = "Build_" ++ map clean (unPackageName (pkgName (package pkg))) + where + clean x | isAlphaNum x = x + | otherwise = '_' + + +-- | Generate the Build_package module for the given package information. +-- +-- This module will export `deps :: [(String,[Int])]` +generateBuildModule :: + Verbosity {- ^ build verbosity -} -> + PackageDescription {- ^ package description -} -> + LocalBuildInfo {- ^ local build information -} -> + [InstalledPackageInfo] {- ^ transitive package dependencies -} -> + IO () +generateBuildModule verbosity pkg lbi pkgs = + do let modname = buildModuleName pkg + dir = autogenModulesDir lbi + file = dir modname <.> "hs" + createDirectoryIfMissingVerbose verbosity True dir + rewriteFile file + $ unlines + [ "{-|" + , "Module : " ++ modname + , "Description : Dynamically generated configuration module" + , "-}" + , "module " ++ modname ++ " (deps) where" + , "" + , "-- | Transitive dependencies for this package computed at configure-time" + , "deps :: [(String,[Int])] -- ^ package name, version number" + , "deps = " ++ renderDeps pkgs + ] + + +-- | Render the transitive package dependencies as a Haskell expression +renderDeps :: + [InstalledPackageInfo] {- ^ transitive package dependencies -} -> + String {- ^ haskell syntax -} +renderDeps pkgs = + show [ (unPackageName (pkgName p), versionBranch (pkgVersion p)) + | p <- sourcePackageId <$> pkgs + ] + + +-- | Check that all transitive dependencies are available under an acceptable +-- license. Raises a user-error on failure. +validateLicenses :: + [InstalledPackageInfo] {- ^ transitive package dependencies -} -> + IO () +validateLicenses pkgs = + do let p pkg = license pkg `notElem` freeLicenses + badPkgs = filter p pkgs + unless (null badPkgs) $ do mapM_ print badPkgs fail "BAD LICENSE" + +-- | The set of permissive licenses that are acceptable for transitive dependencies +-- of this package: BSD2, BSD3, ISC, MIT, PublicDomain freeLicenses :: [License] -freeLicenses = [ BSD2, BSD3, ISC, MIT ] +freeLicenses = [BSD2, BSD3, ISC, MIT, PublicDomain] diff --git a/exec/Main.hs b/exec/Main.hs --- a/exec/Main.hs +++ b/exec/Main.hs @@ -11,12 +11,15 @@ module Main where import Control.Concurrent +import Control.Exception import Control.Lens import Control.Monad +import Data.Default.Class (def) import Data.List (nub) import Data.Text (Text) import System.Exit import System.IO +import Graphics.Vty import Client.Configuration import Client.EventLoop @@ -30,10 +33,12 @@ do opts <- getOptions cfg <- loadConfiguration' (view optConfigFile opts) runInUnboundThread $ - withClientState cfg $ - clientStartExtensions >=> - initialNetworkLogic opts >=> - eventLoop + withClientState cfg $ \st0 -> + withVty $ \vty -> + do st1 <- clientStartExtensions st0 + st2 <- initialNetworkLogic opts st1 + st3 <- updateTerminalSize vty st2 + eventLoop vty st3 initialNetworkLogic :: Options -> ClientState -> IO ClientState initialNetworkLogic opts st = addInitialNetworks (nub networks) st @@ -70,3 +75,8 @@ addInitialNetworks (n:ns) st = do st' <- foldM (flip (addConnection 0 Nothing)) st (n:ns) return $! set clientFocus (NetworkFocus n) st' + +-- | Initialize a 'Vty' value and run a continuation. Shutdown the 'Vty' +-- once the continuation finishes. +withVty :: (Vty -> IO a) -> IO a +withVty = bracket (mkVty def{bracketedPasteMode = Just True}) shutdown diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.18 +version: 2.19 synopsis: Console IRC client description: Console IRC client . @@ -24,6 +24,7 @@ custom-setup setup-depends: base >=4.9 && <4.10, + filepath >1.4 && <1.5, Cabal >=1.24 && <1.25 source-repository head @@ -31,6 +32,11 @@ location: git://github.com/glguy/irc-core.git branch: v2 +flag ExportCApi + description: Export C functions used by the extension API (incompatible with GHCi) + default: True + manual: True + executable glirc2 main-is: Main.hs ghc-options: -threaded -rtsopts @@ -38,13 +44,14 @@ hs-source-dirs: exec default-language: Haskell2010 - if os(Linux) - ld-options: -Wl,--dynamic-list=exec/linux_exported_symbols.txt - if os(Darwin) - ld-options: -Wl,-exported_symbols_list,exec/macos_exported_symbols.txt + if flag(ExportCApi) + if os(Linux) + ld-options: -Wl,--dynamic-list=exec/linux_exported_symbols.txt + if os(Darwin) + ld-options: -Wl,-exported_symbols_list,exec/macos_exported_symbols.txt -- Constraints can be found on the library itself - build-depends: base, glirc, lens, text + build-depends: base, glirc, data-default-class, lens, text, vty library hs-source-dirs: src @@ -109,6 +116,7 @@ StrictUnit Digraphs Paths_glirc + Build_glirc build-depends: base >=4.9 && <4.10, async >=2.1 && <2.2, @@ -118,18 +126,17 @@ connection >=0.2.6 && <0.3, containers >=0.5.7 && <0.6, data-default-class >=0.1.2 && <0.2, - 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, irc-core >=2.2 && <2.3, lens >=4.14 && <4.15, + kan-extensions >=5.0 && <5.1, memory >=0.13 && <0.14, network >=2.6.2 && <2.7, process >=1.4.2 && <1.5, regex-tdfa >=1.2 && <1.3, - regex-tdfa-text >=1.0 && <1.1, socks >=0.5.5 && <0.6, split >=0.2 && <0.3, stm >=2.4 && <2.5, @@ -144,6 +151,9 @@ x509 >=1.6.3 && <1.7, x509-store >=1.6.1 && <1.7, x509-system >=1.6.3 && <1.7 + + if flag(ExportCApi) + cpp-options: -DEXPORT_GLIRC_CAPI test-suite test type: exitcode-stdio-1.0 diff --git a/src/Client/CApi.hs b/src/Client/CApi.hs --- a/src/Client/CApi.hs +++ b/src/Client/CApi.hs @@ -1,4 +1,4 @@ -{-# Language RecordWildCards #-} +{-# Language GeneralizedNewtypeDeriving, RankNTypes, RecordWildCards #-} {-| Module : Client.CApi Description : Dynamically loaded extension API @@ -25,8 +25,8 @@ import Client.CApi.Types import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Cont +import Control.Monad.IO.Class +import Control.Monad.Codensity import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Foreign as Text @@ -96,6 +96,7 @@ runStopExtension f stab (aeSession ae) dlclose (aeDL ae) + -- | Call all of the process message callbacks in the list of extensions. -- This operation marshals the IRC message once and shares that across -- all of the callbacks. @@ -114,8 +115,9 @@ s = aeSession ae , f /= nullFunPtr ] - doNotifications = - runContT (withRawIrcMsg network msg) (go aes') + doNotifications = evalNestedIO $ + do raw <- withRawIrcMsg network msg + liftIO (go aes' raw) -- run handlers until one of them drops the message go [] _ = return True @@ -131,18 +133,18 @@ [Text] {- ^ parameters -} -> ActiveExtension {- ^ extension to command -} -> IO () -commandExtension stab params ae = evalContT $ +commandExtension stab params ae = evalNestedIO $ do cmd <- withCommand params let f = fgnCommand (aeFgn ae) - lift $ unless (f == nullFunPtr) - $ runProcessCommand f stab (aeSession ae) cmd + liftIO $ unless (f == nullFunPtr) + $ runProcessCommand f stab (aeSession ae) cmd -- | Marshal a 'RawIrcMsg' into a 'FgnMsg' which will be valid for -- the remainder of the computation. withRawIrcMsg :: Text {- ^ network -} -> RawIrcMsg {- ^ message -} -> - ContT a IO (Ptr FgnMsg) + NestedIO (Ptr FgnMsg) withRawIrcMsg network RawIrcMsg{..} = do net <- withText network pfxN <- withText $ maybe Text.empty (idText.userNick) _msgPrefix @@ -152,30 +154,45 @@ prms <- traverse withText _msgParams tags <- traverse withTag _msgTags let (keys,vals) = unzip tags - (tagN,keysPtr) <- contT2 $ withArrayLen keys - valsPtr <- ContT $ withArray vals - (prmN,prmPtr) <- contT2 $ withArrayLen prms - ContT $ with $ FgnMsg net pfxN pfxU pfxH cmd prmPtr (fromIntegral prmN) + (tagN,keysPtr) <- nest2 $ withArrayLen keys + valsPtr <- nest1 $ withArray vals + (prmN,prmPtr) <- nest2 $ withArrayLen prms + nest1 $ with $ FgnMsg net pfxN pfxU pfxH cmd prmPtr (fromIntegral prmN) keysPtr valsPtr (fromIntegral tagN) withCommand :: [Text] {- ^ parameters -} -> - ContT a IO (Ptr FgnCmd) + NestedIO (Ptr FgnCmd) withCommand params = do prms <- traverse withText params - (prmN,prmPtr) <- contT2 $ withArrayLen prms - ContT $ with $ FgnCmd prmPtr (fromIntegral prmN) + (prmN,prmPtr) <- nest2 $ withArrayLen prms + nest1 $ with $ FgnCmd prmPtr (fromIntegral prmN) -withTag :: TagEntry -> ContT a IO (FgnStringLen, FgnStringLen) +withTag :: TagEntry -> NestedIO (FgnStringLen, FgnStringLen) withTag (TagEntry k v) = do pk <- withText k pv <- withText v return (pk,pv) -withText :: Text -> ContT a IO FgnStringLen +withText :: Text -> NestedIO FgnStringLen withText txt = - do (ptr,len) <- ContT $ Text.withCStringLen txt + do (ptr,len) <- nest1 $ Text.withCStringLen txt return $ FgnStringLen ptr $ fromIntegral len -contT2 :: ((a -> b -> m c) -> m c) -> ContT c m (a,b) -contT2 f = ContT $ \g -> f $ curry g +------------------------------------------------------------------------ + +-- | Continuation-passing style bracked IO actions. +newtype NestedIO a = NestedIO (Codensity IO a) + deriving (Functor, Applicative, Monad, MonadIO) + +-- | Return the bracket IO action. +evalNestedIO :: NestedIO a -> IO a +evalNestedIO (NestedIO m) = lowerCodensity m + +-- | Wrap up a bracketing IO operation where the continuation takes 1 argument +nest1 :: (forall r. (a -> IO r) -> IO r) -> NestedIO a +nest1 f = NestedIO (Codensity f) + +-- | Wrap up a bracketing IO operation where the continuation takes 2 argument +nest2 :: (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a,b) +nest2 f = NestedIO (Codensity (f . curry)) diff --git a/src/Client/CApi/Exports.hs b/src/Client/CApi/Exports.hs --- a/src/Client/CApi/Exports.hs +++ b/src/Client/CApi/Exports.hs @@ -1,4 +1,4 @@ -{-# Language RecordWildCards #-} +{-# Language CPP, RecordWildCards #-} {-| Module : Client.CApi.Exports Description : Foreign exports which expose functionality for extensions @@ -94,7 +94,9 @@ Ptr FgnMsg {- ^ pointer to message -} -> IO CInt {- ^ 0 on success -} +#ifdef EXPORT_GLIRC_CAPI foreign export ccall "glirc_send_message" glirc_send_message :: Glirc_send_message +#endif glirc_send_message :: Glirc_send_message glirc_send_message token msgPtr = @@ -119,7 +121,9 @@ CSize {- ^ message length -} -> IO CInt {- ^ 0 on success -} +#ifdef EXPORT_GLIRC_CAPI foreign export ccall glirc_print :: Glirc_print +#endif glirc_print :: Glirc_print glirc_print stab code msgPtr msgLen = @@ -147,7 +151,9 @@ Ptr () {- ^ api token -} -> IO (Ptr CString) {- ^ null terminated array of null terminated strings -} +#ifdef EXPORT_GLIRC_CAPI foreign export ccall glirc_list_networks :: Glirc_list_networks +#endif glirc_list_networks :: Glirc_list_networks glirc_list_networks stab = @@ -170,7 +176,9 @@ CSize {- ^ identifier 2 len -} -> IO CInt +#ifdef EXPORT_GLIRC_CAPI foreign export ccall glirc_identifier_cmp :: Glirc_identifier_cmp +#endif glirc_identifier_cmp :: Glirc_identifier_cmp glirc_identifier_cmp p1 n1 p2 n2 = @@ -191,7 +199,9 @@ CSize {- ^ network len -} -> IO (Ptr CString) {- ^ null terminated array of null terminated strings -} +#ifdef EXPORT_GLIRC_CAPI foreign export ccall glirc_list_channels :: Glirc_list_channels +#endif glirc_list_channels :: Glirc_list_channels glirc_list_channels stab networkPtr networkLen = @@ -216,7 +226,9 @@ CSize {- ^ channel len -} -> IO (Ptr CString) {- ^ null terminated array of null terminated strings -} +#ifdef EXPORT_GLIRC_CAPI foreign export ccall glirc_list_channel_users :: Glirc_list_channel_users +#endif glirc_list_channel_users :: Glirc_list_channel_users glirc_list_channel_users stab networkPtr networkLen channelPtr channelLen = @@ -244,7 +256,9 @@ CSize {- ^ network name length -} -> IO CString +#ifdef EXPORT_GLIRC_CAPI foreign export ccall glirc_my_nick :: Glirc_my_nick +#endif glirc_my_nick :: Glirc_my_nick glirc_my_nick stab networkPtr networkLen = @@ -269,7 +283,9 @@ CSize {- ^ channel name length -} -> IO () +#ifdef EXPORT_GLIRC_CAPI foreign export ccall glirc_mark_seen :: Glirc_mark_seen +#endif glirc_mark_seen :: Glirc_mark_seen glirc_mark_seen stab networkPtr networkLen channelPtr channelLen = @@ -298,7 +314,9 @@ CSize {- ^ channel name length -} -> IO () +#ifdef EXPORT_GLIRC_CAPI foreign export ccall glirc_clear_window :: Glirc_clear_window +#endif glirc_clear_window :: Glirc_clear_window glirc_clear_window stab networkPtr networkLen channelPtr channelLen = diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -789,8 +789,13 @@ | otherwise = setWindow Nothing focusEffect - | not isActive && view clientFocus st' == focus = advanceFocus - | otherwise = id + | not isActive && view clientFocus st' == focus = + if has (clientWindows . ix prev) st' + then changeFocus prev + else advanceFocus + | otherwise = id + where + prev = view clientPrevFocus st setWindow = set (clientWindows . at focus) diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -32,6 +32,7 @@ , configUrlOpener , configIgnores , configActivityBar + , configBellOnMention -- * Loading configuration , loadConfiguration @@ -85,6 +86,7 @@ , _configUrlOpener :: Maybe FilePath -- ^ paths to url opening executable , _configIgnores :: HashSet Identifier -- ^ initial ignore list , _configActivityBar :: Bool -- ^ initially visibility of the activity bar + , _configBellOnMention :: Bool -- ^ notify terminal on mention } deriving Show @@ -216,6 +218,8 @@ <$> sectionOptWith (parseList parseIdentifier) "ignores" _configActivityBar <- fromMaybe False <$> sectionOpt "activity-bar" + + _configBellOnMention <- fromMaybe False <$> sectionOpt "bell-on-mention" for_ _configNickPadding (\padding -> when (padding < 0) diff --git a/src/Client/Configuration/Colors.hs b/src/Client/Configuration/Colors.hs --- a/src/Client/Configuration/Colors.hs +++ b/src/Client/Configuration/Colors.hs @@ -56,7 +56,7 @@ case v of Atom "blink" -> pure blink -- You're the boss... Atom "bold" -> pure bold - Atom "dim" -> pure bold + Atom "dim" -> pure dim Atom "reverse-video" -> pure reverseVideo Atom "standout" -> pure standout Atom "underline" -> pure underline diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -13,6 +13,7 @@ module Client.EventLoop ( eventLoop + , updateTerminalSize ) where import qualified Client.Authentication.Ecdsa as Ecdsa @@ -65,8 +66,11 @@ -- | Block waiting for the next 'ClientEvent'. This function will compute -- an appropriate timeout based on the current connections. -getEvent :: ClientState -> IO ClientEvent -getEvent st = +getEvent :: + Vty {- ^ vty handle -} -> + ClientState {- ^ client state -} -> + IO ClientEvent +getEvent vty st = do timer <- prepareTimer atomically $ asum [ timer @@ -74,7 +78,7 @@ , NetworkEvent <$> readTQueue (view clientEvents st) ] where - vtyEventChannel = _eventChannel (inputIface (view clientVty st)) + vtyEventChannel = _eventChannel (inputIface vty) prepareTimer = case earliestEvent st of @@ -95,21 +99,20 @@ (comparing (fst . snd)) -- | Apply this function to an initial 'ClientState' to launch the client. -eventLoop :: ClientState -> IO () -eventLoop st = - do let vty = view clientVty st - when (view clientBell st) (beep vty) +eventLoop :: Vty -> ClientState -> IO () +eventLoop vty st = + do when (view clientBell st) (beep vty) processLogEntries st let (pic, st') = clientPicture (clientTick st) update vty pic - event <- getEvent st' + event <- getEvent vty st' case event of - TimerEvent networkId action -> eventLoop =<< doTimerEvent networkId action st' - VtyEvent vtyEvent -> traverse_ eventLoop =<< doVtyEvent vtyEvent st' + TimerEvent networkId action -> eventLoop vty =<< doTimerEvent networkId action st' + VtyEvent vtyEvent -> traverse_ (eventLoop vty) =<< doVtyEvent vty vtyEvent st' NetworkEvent networkEvent -> - eventLoop =<< + eventLoop vty =<< case networkEvent of NetworkLine net time line -> doNetworkLine net time line st' NetworkError net time ex -> doNetworkError net time ex st' @@ -373,19 +376,24 @@ lookups ks m = mapMaybe (\k -> preview (ix k) m) ks +-- | Update the height and width fields of the client state +updateTerminalSize :: Vty -> ClientState -> IO ClientState +updateTerminalSize vty st = + do (w,h) <- displayBounds (outputIface vty) + return $! set clientWidth w + $ set clientHeight h st + -- | Respond to a VTY event. doVtyEvent :: + Vty {- ^ vty handle -} -> Event {- ^ vty event -} -> ClientState {- ^ client state -} -> IO (Maybe ClientState) {- ^ nothing when finished -} -doVtyEvent vtyEvent st = +doVtyEvent vty vtyEvent st = case vtyEvent of - EvKey k modifier -> doKey k modifier st - EvResize{} -> -- ignore event parameters due to raw TChan use - do let vty = view clientVty st - (w,h) <- displayBounds (outputIface vty) - return $! Just $! set clientWidth w - $ set clientHeight h st + EvKey k modifier -> doKey vty k modifier st + -- ignore event parameters due to raw TChan use + EvResize{} -> Just <$> updateTerminalSize vty st EvPaste utf8 -> do let str = Text.unpack (Text.decodeUtf8With Text.lenientDecode utf8) return $! Just $! over clientTextBox (Edit.insertPaste str) st @@ -394,11 +402,12 @@ -- | Map keyboard inputs to actions in the client doKey :: + Vty {- ^ vty handle -} -> Key {- ^ key pressed -} -> [Modifier] {- ^ modifiers held -} -> ClientState {- ^ client state -} -> IO (Maybe ClientState) -doKey key modifier st = +doKey vty key modifier st = let continue !out = return (Just out) changeEditor f = continue (over clientTextBox f st) changeContent f = changeEditor @@ -430,7 +439,7 @@ KChar 'p' -> continue (retreatFocus st) KChar 'n' -> continue (advanceFocus st) KChar 'x' -> continue (advanceNetworkFocus st) - KChar 'l' -> do refresh (view clientVty st) + KChar 'l' -> do refresh vty continue st _ -> continue st diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -45,10 +45,11 @@ (mainHeight, splitHeight) = clientWindowHeights (imageHeight activityBar) st splitFocuses = clientExtraFocuses st focus = view clientFocus st - (pos , tbImg ) = textboxImage st + (pos , nextOffset, tbImg) = textboxImage st -- update client state for scroll clamp - st' = over clientScroll (max 0 . subtract overscroll) st + !st' = set clientTextBoxOffset nextOffset + $ over clientScroll (max 0 . subtract overscroll) st (overscroll, msgs) = messagePane mainHeight focus (view clientSubfocus st) st splits = renderExtra st' <$> splitFocuses diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -22,6 +22,7 @@ , coloredIdentifier , cleanText , cleanChar + , rightPad ) where import Client.Image.MircFormatting diff --git a/src/Client/Image/Textbox.hs b/src/Client/Image/Textbox.hs --- a/src/Client/Image/Textbox.hs +++ b/src/Client/Image/Textbox.hs @@ -35,24 +35,35 @@ -- | Compute the UI image for the text input box. This computes -- the logical cursor position on the screen to compensate for -- VTY's cursor placement behavior. -textboxImage :: ClientState -> (Int, Image) -- ^ cursor column, image +textboxImage :: ClientState -> (Int, Int, Image) -- ^ cursor column, new offset, image textboxImage st - = (pos, croppedImage) + = (newPos, newOffset, croppedImage) where width = view clientWidth st macros = views (clientConfig . configMacros) (fmap macroSpec) st (txt, content) = views (clientTextBox . Edit.content) (renderContent macros pal) st - pos = min (width-1) leftOfCurWidth - lineImage = beginning <|> content <|> ending leftOfCurWidth = myWcswidth ('^':txt) - croppedImage - | leftOfCurWidth < width = lineImage - | otherwise = cropLeft width (cropRight (leftOfCurWidth+1) lineImage) + croppedImage = cropLeft (imageWidth lineImage - newOffset) lineImage + + cursorAnchor = width * 3 `quot` 4 + + -- previous offset value + oldOffset = view clientTextBoxOffset st + + -- position based on old offset + oldPos = leftOfCurWidth - oldOffset + + -- new offset (number of columns to trim from left side of text box) + newOffset + | 0 <= oldPos, oldPos < width = oldOffset + | otherwise = max 0 (leftOfCurWidth - cursorAnchor) + + newPos = leftOfCurWidth - newOffset pal = clientPalette st attr = view palTextBox pal diff --git a/src/Client/Options.hs b/src/Client/Options.hs --- a/src/Client/Options.hs +++ b/src/Client/Options.hs @@ -1,4 +1,4 @@ -{-# Language TemplateHaskell, MultiWayIf #-} +{-# Language CPP, TemplateHaskell, MultiWayIf #-} {-| Module : Client.Options Description : Processing of command-line options @@ -25,6 +25,7 @@ import Control.Lens import Data.Foldable +import Data.List import Data.Text (Text) import qualified Data.Text as Text import Data.Version @@ -33,7 +34,9 @@ import System.Environment import System.Exit import System.IO +import System.Info import Paths_glirc (version) +import Build_glirc (deps) -- | Command-line options data Options = Options @@ -42,6 +45,7 @@ , _optNoConnect :: Bool -- ^ disable autoconnect , _optShowHelp :: Bool -- ^ show help message , _optShowVersion :: Bool -- ^ show version message + , _optShowFullVersion :: Bool -- ^ show version of ALL transitive dependencies } makeLenses ''Options @@ -53,6 +57,7 @@ , _optInitialNetworks = [] , _optShowHelp = False , _optShowVersion = False + , _optShowFullVersion = False , _optNoConnect = False } @@ -67,6 +72,8 @@ "Show help" , Option "v" ["version"] (NoArg (set optShowVersion True)) "Show version" + , Option "" ["full-version"] (NoArg (set optShowFullVersion True)) + "Show version and versions of all linked Haskell libraries" ] optOrder :: ArgOrder (Options -> Options) @@ -88,6 +95,7 @@ hPutStrLn stderr tryHelpTxt if | view optShowHelp opts -> putStr helpTxt >> exitSuccess + | view optShowFullVersion opts -> putStr fullVersionTxt >> exitSuccess | view optShowVersion opts -> putStr versionTxt >> exitSuccess | null errors -> return opts | otherwise -> reportErrors >> exitFailure @@ -99,11 +107,32 @@ tryHelpTxt = "Run 'glirc2 --help' to see a list of available command line options." +-- version information --------------------------------------------- + versionTxt :: String versionTxt = unlines [ "glirc-" ++ showVersion version ++ gitHashTxt ++ gitDirtyTxt , "Copyright 2016 Eric Mertens" ] + +fullVersionTxt :: String +fullVersionTxt = + versionTxt ++ + unlines + ("" + :("OS : " ++ os) + :("Architecture: " ++ arch) + :("Compiler : " ++ compilerName ++ "-" ++ showVersion compilerVersion) + :"" + :("ghc : " ++ TOOL_VERSION_ghc) + :("ghc-pkg : " ++ TOOL_VERSION_ghc_pkg) + :("alex : " ++ TOOL_VERSION_alex) + :("happy : " ++ TOOL_VERSION_happy) + :("hsc2hs : " ++ TOOL_VERSION_hsc2hs) + :"" + :"Transitive dependencies:" + : [ name ++ "-" ++ intercalate "." (map show ver) | (name,ver) <- sort deps ] + ) -- git version information --------------------------------------------- diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -18,12 +18,13 @@ -- * Lenses , clientWindows , clientTextBox + , clientTextBoxOffset , clientConnections , clientWidth , clientHeight , clientEvents - , clientVty , clientFocus + , clientPrevFocus , clientExtraFocus , clientConnectionContext , clientConfig @@ -114,11 +115,9 @@ import Control.Applicative import Control.Concurrent.MVar import Control.Concurrent.STM -import Control.DeepSeq import Control.Exception import Control.Lens import Control.Monad -import Data.Default.Class import Data.Foldable import Data.Either import Data.HashMap.Strict (HashMap) @@ -135,7 +134,6 @@ import Data.Time import Foreign.Ptr import Foreign.StablePtr -import Graphics.Vty hiding ((<|>)) import Irc.Codes import Irc.Identifier import Irc.Message @@ -145,7 +143,6 @@ import Network.Connection (ConnectionContext, initConnectionContext) import Text.Regex.TDFA import Text.Regex.TDFA.String (compile) -import Text.Regex.TDFA.Text () -- RegexLike Regex Text orphan -- | All state information for the IRC client data ClientState = ClientState @@ -163,8 +160,8 @@ , _clientConfig :: !Configuration -- ^ client configuration - , _clientVty :: !Vty -- ^ VTY handle , _clientTextBox :: !Edit.EditBox -- ^ primary text box + , _clientTextBoxOffset :: !Int -- ^ size to crop from left of text box , _clientWidth :: !Int -- ^ current terminal width , _clientHeight :: !Int -- ^ current terminal height @@ -172,7 +169,7 @@ , _clientDetailView :: !Bool -- ^ use detailed rendering mode , _clientActivityBar :: !Bool -- ^ visible activity bar , _clientShowMetadata :: !Bool -- ^ visible activity bar - , _clientRegex :: (Maybe Regex) -- ^ optional persistent filter + , _clientRegex :: Maybe Regex -- ^ optional persistent filter , _clientBell :: !Bool -- ^ sound a bell next draw @@ -223,11 +220,9 @@ withClientState :: Configuration -> (ClientState -> IO a) -> IO a withClientState cfg k = - withVty $ \vty -> withExtensionState $ \exts -> - do (width,height) <- displayBounds (outputIface vty) - cxt <- initConnectionContext + do cxt <- initConnectionContext events <- atomically newTQueue k ClientState { _clientWindows = _Empty # () @@ -235,9 +230,9 @@ , _clientIgnores = view configIgnores cfg , _clientConnections = _Empty # () , _clientTextBox = Edit.defaultEditBox - , _clientWidth = width - , _clientHeight = height - , _clientVty = vty + , _clientTextBoxOffset = 0 + , _clientWidth = 80 + , _clientHeight = 25 , _clientEvents = events , _clientPrevFocus = Unfocused , _clientFocus = Unfocused @@ -256,11 +251,6 @@ , _clientLogQueue = [] } --- | Initialize a 'Vty' value and run a continuation. Shutdown the 'Vty' --- once the continuation finishes. -withVty :: (Vty -> IO a) -> IO a -withVty = bracket (mkVty def{bracketedPasteMode = Just True}) shutdown - withExtensionState :: (ExtensionState -> IO a) -> IO a withExtensionState k = do mvar <- newEmptyMVar @@ -467,10 +457,22 @@ WindowLine -> ClientState -> ClientState -recordWindowLine focus wl = - over (clientWindows . at focus) - (\w -> Just $! addToWindow wl (fromMaybe emptyWindow w)) +recordWindowLine focus wl st = st2 + where + st1 = over (clientWindows . at focus) + (\w -> Just $! addToWindow wl (fromMaybe emptyWindow w)) + st + st2 + | not (view clientBell st) + , view (clientConfig . configBellOnMention) st + , view wlImportance wl == WLImportant + , not (hasMention st) = set clientBell True st1 + + | otherwise = st1 + + hasMention = orOf (clientWindows . folded . winMention) + toWindowLine :: MessageRendererParams -> WindowLineImportance -> ClientMessage -> WindowLine toWindowLine params importance msg = WindowLine { _wlSummary = msgSummary (view msgBody msg) @@ -482,7 +484,7 @@ } where mkImage mode = - force (msgImage mode (view msgTime msg) params (view msgBody msg)) + msgImage mode (view msgTime msg) params (view msgBody msg) -- | 'toWindowLine' but with mostly defaulted parameters. toWindowLine' :: Configuration -> WindowLineImportance -> ClientMessage -> WindowLine @@ -554,7 +556,7 @@ clientMatcher st = case clientActiveRegex st of Nothing -> const True - Just r -> matchTest r + Just r -> matchTest r . Text.unpack -- | Construct a text matching predicate used to filter the message window. clientActiveRegex :: ClientState -> Maybe Regex @@ -593,8 +595,11 @@ \]*>" urlMatches :: Text -> [Text] -urlMatches = map removeBrackets . getAllTextMatches . match urlPattern +urlMatches txt = removeBrackets . extractText . (^?! ix 0) + <$> matchAll urlPattern (Text.unpack txt) where + extractText (off,len) = Text.take len (Text.drop off txt) + removeBrackets t = case Text.uncons t of Just ('<',t') | not (Text.null t') -> Text.init t' diff --git a/src/Client/View/UrlSelection.hs b/src/Client/View/UrlSelection.hs --- a/src/Client/View/UrlSelection.hs +++ b/src/Client/View/UrlSelection.hs @@ -13,13 +13,20 @@ ( urlSelectionView ) where -import Client.State -import Client.State.Window +import Client.Configuration import Client.Image.Message +import Client.Image.Palette +import Client.Message +import Client.State import Client.State.Focus +import Client.State.Network +import Client.State.Window import Control.Lens +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet import Data.Text (Text) import Graphics.Vty.Image +import Irc.Identifier import Text.Read (readMaybe) @@ -30,26 +37,57 @@ ClientState {- ^ client state -} -> [Image] {- ^ image lines -} urlSelectionView focus arg st = - zipWith (draw selected) [1..] (toListOf urled st) + zipWith (draw me pal padding selected) [1..] (toListOf urled st) where urled = clientWindows . ix focus . winMessages . each - . wlText . folding urlMatches + . folding matches selected | all (==' ') arg = 1 | Just i <- readMaybe arg = i | otherwise = 0 -- won't match + cfg = view clientConfig st + padding = view configNickPadding cfg + pal = view configPalette cfg + me = maybe HashSet.empty HashSet.singleton + $ do net <- focusNetwork focus + preview (clientConnection net . csNick) st + + +matches :: WindowLine -> [(Maybe Identifier, Text)] +matches wl = [ (views wlSummary summaryActor wl, url) | url <- views wlText urlMatches wl ] + +summaryActor :: IrcSummary -> Maybe Identifier +summaryActor s = + case s of + JoinSummary who -> Just who + QuitSummary who -> Just who + PartSummary who -> Just who + NickSummary who _ -> Just who + ChatSummary who -> Just who + CtcpSummary who -> Just who + ReplySummary {} -> Nothing + NoSummary -> Nothing + + -- | Render one line of the url list draw :: - Int {- ^ selected index -} -> - Int {- ^ url index -} -> - Text {- ^ url text -} -> - Image {- ^ rendered line -} -draw selected i url = string attr (shows i ". ") <|> - text' attr (cleanText url) + HashSet Identifier {- ^ my nick -} -> + Palette {- ^ palette -} -> + Maybe Integer {- ^ nick render padding -} -> + Int {- ^ selected index -} -> + Int {- ^ url index -} -> + (Maybe Identifier, Text) {- ^ sender and url text -} -> + Image {- ^ rendered line -} +draw me pal padding selected i (who,url) = + rightPad NormalRender padding + (foldMap (coloredIdentifier pal NormalIdentifier me) who) <|> + string defAttr ": " <|> + string attr (shows i ". ") <|> + text' attr (cleanText url) where attr | selected == i = withStyle defAttr reverseVideo | otherwise = defAttr