glirc 2.18 → 2.19

raw patch · 17 files changed

+389/−115 lines, 17 filesdep +kan-extensionsdep −deepseqdep −regex-tdfa-textdep ~data-default-classdep ~vtysetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: kan-extensions

Dependencies removed: deepseq, regex-tdfa-text

Dependency ranges changed: data-default-class, vty

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• README.md +1/−0
• Setup.hs +121/−14
• exec/Main.hs +14/−4
• glirc.cabal +18/−8
• src/Client/CApi.hs +38/−21
• src/Client/CApi/Exports.hs +19/−1
• src/Client/Commands.hs +7/−2
• src/Client/Configuration.hs +4/−0
• src/Client/Configuration/Colors.hs +1/−1
• src/Client/EventLoop.hs +29/−20
• src/Client/Image.hs +3/−2
• src/Client/Image/Message.hs +1/−0
• src/Client/Image/Textbox.hs +18/−7
• src/Client/Options.hs +30/−1
• src/Client/State.hs +29/−24
• src/Client/View/UrlSelection.hs +48/−10

@@ -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`

@@ -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

@@ -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]

@@ -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

@@ -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

@@ -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))

@@ -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 =

@@ -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) 

@@ -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)

@@ -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

@@ -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 

@@ -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

@@ -22,6 +22,7 @@   , coloredIdentifier   , cleanText   , cleanChar+  , rightPad   ) where  import           Client.Image.MircFormatting

@@ -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

@@ -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 --------------------------------------------- 

@@ -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 @@     \<https?://[^>]*>"  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'

@@ -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