Open URLs by right-clicking on them

.hlint.yaml

@@ -0,0 +1,68 @@
+# HLint configuration file
+# https://github.com/ndmitchell/hlint
+##########################
+
+# This file contains a template configuration file, which is typically
+# placed as .hlint.yaml in the root of your project
+
+
+# Specify additional command line arguments
+#
+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
+
+
+# Control which extensions/flags/modules/functions can be used
+#
+# - extensions:
+#   - default: false # all extension are banned by default
+#   - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
+#   - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
+#
+# - flags:
+#   - {name: -w, within: []} # -w is allowed nowhere
+#
+# - modules:
+#   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
+#   - {name: Control.Arrow, within: []} # Certain modules are banned entirely
+#
+# - functions:
+#   - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
+
+
+# Add custom hints for this project
+#
+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
+
+# The hints are named by the string they display in warning messages.
+# For example, if you see a warning starting like
+#
+# Main.hs:116:51: Warning: Redundant ==
+#
+# You can refer to that hint with `{name: Redundant ==}` (see below).
+
+# Turn on hints that are off by default
+#
+# Ban "module X(module X) where", to require a real export list
+# - warn: {name: Use explicit module export list}
+#
+# Replace a $ b $ c with a . b $ c
+# - group: {name: dollar, enabled: true}
+#
+# Generalise map to fmap, ++ to <>
+# - group: {name: generalise, enabled: true}
+
+
+# Ignore some builtin hints
+# - ignore: {name: Use let}
+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
+- ignore: {name: Use forM_}
+- ignore: {name: Use join}
+
+
+# Define some custom infix operators
+# - fixity: infixr 3 ~^#^~
+
+
+# To generate a suitable file for HLint do:
+# $ hlint --default > .hlint.yaml

README.md

@@ -495,6 +495,25 @@ see the documentation in the
 [`.nix-helpers/termonad-with-packages.nix`](./.nix-helpers/termonad-with-packages.nix)
 file.
 
+## Additional Info
+
+This section contains some additional info that may be helpful for using Termonad.
+
+### Opening URLs by right-clicking
+
+It is possible to open a URL in a browser by right-clicking on it, and
+selecting `Open URL in browser`.  In order for this you work, you may
+have to setup your XDG defaults.  You can set the default browser to
+Firefox with a command like the following:
+
+```console
+$ xdg-mime default firefox.desktop x-scheme-handler/http
+$ xdg-mime default firefox.desktop x-scheme-handler/https
+```
+
+This `xdg-mime` executable comes from a package called `xdg-utils` in both
+Nixpkgs and Ubutun/Debian.
+
 ## Goals
 
 Termonad has the following goals:

src/Termonad/Term.hs

@@ -8,20 +8,25 @@ import Control.Lens ((^.), (.~), set, to)
 import Data.Colour.SRGB (Colour, RGB(RGB), toSRGB)
 import Data.FocusList (appendFL, deleteFL, getFocusItemFL)
 import GI.Gdk
-  ( EventButton
+  ( Event (Event)
+  , EventButton
   , EventKey
   , RGBA
   , getEventButtonButton
   , newZeroRGBA
   , setRGBABlue
   , setRGBAGreen
   , setRGBARed
+  , pattern BUTTON_SECONDARY
+  , pattern CURRENT_TIME
   )
-import GI.Gdk.Constants (pattern BUTTON_SECONDARY)
 import GI.Gio
   ( Cancellable
+  , actionMapAddAction
   , menuAppend
   , menuNew
+  , onSimpleActionActivate
+  , simpleActionNew
   )
 import GI.GLib
   ( SpawnFlags(SpawnFlagsDefault)
@@ -40,6 +45,7 @@ import GI.Gtk
   , ReliefStyle(ReliefStyleNone)
   , ResponseType(ResponseTypeNo, ResponseTypeYes)
   , ScrolledWindow
+  , Window
   , applicationGetActiveWindow
   , boxNew
   , buttonNewFromIconName
@@ -71,6 +77,7 @@ import GI.Gtk
   , scrolledWindowNew
   , scrolledWindowSetPolicy
   , setWidgetMargin
+  , showUriOnWindow
   , widgetDestroy
   , widgetGrabFocus
   , widgetSetCanFocus
@@ -86,7 +93,11 @@ import GI.Vte
   , Terminal
   , onTerminalChildExited
   , onTerminalWindowTitleChanged
+  , regexNewForMatch
+  , terminalGetAllowHyperlink
   , terminalGetWindowTitle
+  , terminalMatchAddRegex
+  , terminalMatchCheckEvent
   , terminalNew
   , terminalSetBoldIsBright
   , terminalSetCursorBlinkMode
@@ -133,6 +144,9 @@ import Termonad.Types
   , tmNotebookTabTermContainer
   , tmNotebookTabs
   )
+import Data.Coerce (coerce)
+import Data.GI.Base (toManagedPtr)
+import Termonad.Pcre (pcre2Multiline)
 
 focusTerm :: Int -> TMState -> IO ()
 focusTerm i mvarTMState = do
@@ -473,9 +487,26 @@ createTerm handleKeyPress mvarTMState = do
     relabelTab notebook tabLabel scrolledWin vteTerm
   void $ onWidgetKeyPressEvent vteTerm $ handleKeyPress mvarTMState
   void $ onWidgetKeyPressEvent scrolledWin $ handleKeyPress mvarTMState
-  void $ onWidgetButtonPressEvent vteTerm $ handleMousePress vteTerm
+  void $ onWidgetButtonPressEvent vteTerm $ handleMousePress tmStateAppWin vteTerm
   void $ onTerminalChildExited vteTerm $ \_ -> termExit notebookTab mvarTMState
 
+  -- Underline URLs so that the user can see they are right-clickable.
+  --
+  -- This regex is from https://www.regextester.com/94502
+  --
+  -- TODO: Roxterm and gnome-terminal have a much more in-depth set of regexes
+  -- for URLs and things similar to URLs.  At some point it might make sense to
+  -- switch to something like this:
+  -- https://github.com/realh/roxterm/blob/30f1faf8be4ccac8ba12b59feb5b8f758bc65a7b/src/roxterm-regex.c
+  -- and
+  -- https://github.com/realh/roxterm/blob/30f1faf8be4ccac8ba12b59feb5b8f758bc65a7b/src/terminal-regex.h
+  let regexPat =
+        "(?:http(s)?:\\/\\/)[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+"
+  -- We must set the pcre2Multiline option, otherwise VTE prints a warning.
+  let pcreFlags = fromIntegral pcre2Multiline
+  regex <- regexNewForMatch regexPat (fromIntegral $ length regexPat) pcreFlags
+  void $ terminalMatchAddRegex vteTerm regex 0
+
   -- Put the keyboard focus on the term
   setFocusOn tmStateAppWin vteTerm
 
@@ -487,16 +518,43 @@ createTerm handleKeyPress mvarTMState = do
   pure tmTerm
 
 -- | Popup the context menu on right click
-handleMousePress :: Terminal -> EventButton -> IO Bool
-handleMousePress vteTerm event = do
-  button <- getEventButtonButton event
+handleMousePress :: ApplicationWindow -> Terminal -> EventButton -> IO Bool
+handleMousePress win vteTerm eventButton = do
+  x <- terminalGetAllowHyperlink vteTerm
+  print x
+  button <- getEventButtonButton eventButton
   let rightClick = button == fromIntegral BUTTON_SECONDARY
   when rightClick $ do
     menuModel <- menuNew
+
+    -- if the user right-clicked on a URL, add an option to open the URL
+    -- in a browser
+    (maybeUrl, _regexId) <- terminalMatchCheckEvent vteTerm (eventButtonToEvent eventButton)
+    case maybeUrl of
+      Nothing -> pure ()
+      Just url -> do
+        openUrlAction <- simpleActionNew "openurl" Nothing
+        void $ onSimpleActionActivate openUrlAction $ \_ ->
+          showUriOnWindow (Nothing :: Maybe Window) url (fromIntegral CURRENT_TIME)
+        -- This will add the openurl action to the Application Window's action
+        -- map everytime the user right-clicks on a URL.  It is okay to add
+        -- actions multiple times.
+        actionMapAddAction win openUrlAction
+        menuAppend menuModel (Just "Open URL in browser") (Just "win.openurl")
+
+
     menuAppend menuModel (Just "Copy") (Just "app.copy")
     menuAppend menuModel (Just "Paste") (Just "app.paste")
     menuAppend menuModel (Just "Preferences") (Just "app.preferences")
     menu <- menuNewFromModel menuModel
     menuAttachToWidget menu vteTerm Nothing
     menuPopupAtPointer menu Nothing
   pure rightClick
+
+-- The terminalMatchCheckEvent function takes an Event, while we only
+-- have an EventButton.  It is apparently okay to just cast an EventButton
+-- to an Event, since they are just pointers under the hood, and they
+-- are laid out the same in memory.  See
+-- https://github.com/haskell-gi/haskell-gi/issues/109
+eventButtonToEvent :: EventButton -> Event
+eventButtonToEvent = Event . coerce . toManagedPtr