Add initial external link widget

app/Main.hs

@@ -143,6 +143,7 @@ handleAppEvent wenv node model evt = case evt of
 buildUI :: WidgetEnv App AppEvent -> App -> WidgetNode App AppEvent
 buildUI wenv model = traceShow "Creating UI" widgetSlider where
   widgetSlider = vstack [
+      hstack [externalLink "Launch GitHub" "http://www.github.com"],
       colorPicker,
       labelS (model ^. int1),
       hslider_ int1 (-100) 100 [sliderRadius 10, sliderWidth 20],

package.yaml

@@ -40,6 +40,7 @@ dependencies:
 - mtl
 - nanovg
 - OpenGL
+- process
 - safe
 - sdl2
 - stm

src/Monomer/Core/ThemeTypes.hs

@@ -55,6 +55,7 @@ data ThemeState = ThemeState {
   _thsDropdownListStyle :: StyleState,
   _thsDropdownItemStyle :: StyleState,
   _thsDropdownItemSelectedStyle :: StyleState,
+  _thsExternalLinkStyle :: StyleState,
   _thsInputNumericStyle :: StyleState,
   _thsInputTextStyle :: StyleState,
   _thsLabelStyle :: StyleState,
@@ -100,6 +101,7 @@ instance Default ThemeState where
     _thsDropdownListStyle = def,
     _thsDropdownItemStyle = def,
     _thsDropdownItemSelectedStyle = def,
+    _thsExternalLinkStyle = def,
     _thsInputNumericStyle = def,
     _thsInputTextStyle = def,
     _thsLabelStyle = def,
@@ -145,6 +147,7 @@ instance Semigroup ThemeState where
     _thsDropdownListStyle = _thsDropdownListStyle t1 <> _thsDropdownListStyle t2,
     _thsDropdownItemStyle = _thsDropdownItemStyle t1 <> _thsDropdownItemStyle t2,
     _thsDropdownItemSelectedStyle = _thsDropdownItemSelectedStyle t1 <> _thsDropdownItemSelectedStyle t2,
+    _thsExternalLinkStyle = _thsExternalLinkStyle t1 <> _thsExternalLinkStyle t2,
     _thsInputNumericStyle = _thsInputNumericStyle t1 <> _thsInputNumericStyle t2,
     _thsInputTextStyle = _thsInputTextStyle t1 <> _thsInputTextStyle t2,
     _thsLabelStyle = _thsLabelStyle t1 <> _thsLabelStyle t2,

src/Monomer/Core/Themes/BaseTheme.hs

@@ -46,6 +46,7 @@ data BaseThemeColors = BaseThemeColors {
   disabledBg :: Color,
   disabledText :: Color,
   emptyOverlay :: Color,
+  externalLinkColor :: Color,
   focusBorder :: Color,
   iconFg :: Color,
   inputBorder :: Color,
@@ -177,6 +178,7 @@ baseBasic themeMod = def
   & L.dropdownListStyle . L.bgColor ?~ lvMainBg themeMod
   & L.dropdownItemStyle .~ listViewItemStyle themeMod
   & L.dropdownItemSelectedStyle .~ listViewItemSelectedStyle themeMod
+  & L.externalLinkStyle . L.text ?~ (normalFont & L.fontColor ?~ externalLinkColor themeMod)
   & L.inputNumericStyle .~ numericInputStyle themeMod
   & L.inputTextStyle .~ inputStyle themeMod
   & L.labelStyle . L.text
@@ -227,6 +229,8 @@ baseHover themeMod = baseBasic themeMod
   & L.dropdownItemSelectedStyle . L.bgColor ?~ lvSelectedBgHover themeMod
   & L.dropdownItemSelectedStyle . L.border ?~ border 1 (lvSelectedBgHover themeMod)
   & L.dropdownItemSelectedStyle . L.cursorIcon ?~ CursorHand
+  & L.externalLinkStyle . L.text . non def . L.underline ?~ True
+  & L.externalLinkStyle . L.cursorIcon ?~ CursorHand
   & L.inputNumericStyle . L.cursorIcon ?~ CursorIBeam
   & L.inputTextStyle . L.cursorIcon ?~ CursorIBeam
   & L.listViewItemStyle . L.bgColor ?~ lvNormalBgHover themeMod

src/Monomer/Core/Themes/SampleThemes.hs

@@ -17,6 +17,7 @@ darkTheme = baseTheme darkMod where
   blueMid = rgb 20 20 255
   blueLight = rgb 40 40 255
   blueHighlight = rgb 135 206 250
+  blueLink = rgb 88 166 255
   grayDisabled = rgb 50 50 50
   grayDarker = rgb 40 40 40
   grayDark = rgb 80 80 80
@@ -43,6 +44,7 @@ darkTheme = baseTheme darkMod where
     disabledBg = grayDisabled,
     disabledText = grayMid,
     emptyOverlay = grayMid & L.a .~ 0.8,
+    externalLinkColor = blueLink,
     focusBorder = blueHighlight,
     iconFg = black,
     inputBorder = grayBorder,

src/Monomer/Core/Util.hs

@@ -99,7 +99,7 @@ isResizeResult result = isJust resizeReq where
   resizeReq = Seq.findIndexL isResizeWidgets requests
 
 isMacOS :: WidgetEnv s e -> Bool
-isMacOS wenv = _weOS wenv == "Mac OS X"
+isMacOS wenv = _weOs wenv == "Mac OS X"
 
 seqStartsWith :: Eq a => Seq a -> Seq a -> Bool
 seqStartsWith prefix seq = Seq.take (length prefix) seq == prefix

src/Monomer/Core/WidgetTypes.hs

@@ -150,7 +150,7 @@ data LayoutDirection
   deriving (Eq, Show, Generic)
 
 data WidgetEnv s e = WidgetEnv {
-  _weOS :: Text,
+  _weOs :: Text,
   _weRenderer :: Renderer,
   _weFindByPath :: Path -> Maybe WidgetNodeInfo,
   _weMainButton :: Button,
@@ -386,7 +386,7 @@ instance Show (WidgetResult s e) where
 
 instance Show (WidgetEnv s e) where
   show wenv = "WidgetEnv "
-    ++ "{ _weOS: " ++ show (_weOS wenv)
+    ++ "{ _weOs: " ++ show (_weOs wenv)
     ++ ", _weWindowSize: " ++ show (_weWindowSize wenv)
     ++ ", _weFocusedPath: " ++ show (_weFocusedPath wenv)
     ++ ", _weTimestamp: " ++ show (_weTimestamp wenv)

src/Monomer/Main/Core.hs

@@ -112,7 +112,7 @@ runApp window widgetRoot config = do
   liftIO $ endFrame renderer
 
   let wenv = WidgetEnv {
-    _weOS = os,
+    _weOs = os,
     _weRenderer = renderer,
     _weFindByPath = const Nothing,
     _weMainButton = mainBtn,
@@ -205,7 +205,7 @@ mainLoop window renderer config loopArgs = do
   let newSecond = _mlFrameAccumTs > 1000
   let mainBtn = fromMaybe LeftBtn (_apcMainButton config)
   let wenv = WidgetEnv {
-    _weOS = _mlOS,
+    _weOs = _mlOS,
     _weRenderer = renderer,
     _weFindByPath = const Nothing,
     _weMainButton = mainBtn,

src/Monomer/Widgets.hs

@@ -25,6 +25,7 @@ module Monomer.Widgets (
   module Monomer.Widgets.Singles.Checkbox,
   module Monomer.Widgets.Singles.ColorPicker,
   module Monomer.Widgets.Singles.Dial,
+  module Monomer.Widgets.Singles.ExternalLink,
   module Monomer.Widgets.Singles.Icon,
   module Monomer.Widgets.Singles.Image,
   module Monomer.Widgets.Singles.Label,
@@ -62,6 +63,7 @@ import Monomer.Widgets.Singles.Button
 import Monomer.Widgets.Singles.Checkbox
 import Monomer.Widgets.Singles.ColorPicker
 import Monomer.Widgets.Singles.Dial
+import Monomer.Widgets.Singles.ExternalLink
 import Monomer.Widgets.Singles.Icon
 import Monomer.Widgets.Singles.Image
 import Monomer.Widgets.Singles.Label

src/Monomer/Widgets/Composite.hs

@@ -773,7 +773,7 @@ collectGlobalKeys keys node = newMap where
 
 convertWidgetEnv :: WidgetEnv sp ep -> WidgetKeysMap s e -> s -> WidgetEnv s e
 convertWidgetEnv wenv globalKeys model = WidgetEnv {
-  _weOS = _weOS wenv,
+  _weOs = _weOs wenv,
   _weRenderer = _weRenderer wenv,
   _weFindByPath = _weFindByPath wenv,
   _weMainButton = _weMainButton wenv,

src/Monomer/Widgets/Singles/ColorPicker.hs

@@ -91,7 +91,7 @@ buildUI config wenv model = mainTree where
     ]
   colorRow lens lbl = compRow lens lbl 0 255
   alphaRow lens lbl = compRow lens lbl 0 1
-  mainTree = hstack [
+  mainTree = hstack_ [sizeReqUpdater clearExtra] [
       vstack [
         colorRow L.r "Red",
         spacer_ [height 2],

src/Monomer/Widgets/Singles/ExternalLink.hs

@@ -0,0 +1,234 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Monomer.Widgets.Singles.ExternalLink (
+  externalLink,
+  externalLink_
+) where
+
+import Control.Applicative ((<|>))
+import Control.Exception (SomeException, catch)
+import Control.Lens ((&), (^.), (.~))
+import Data.Default
+import Data.Maybe
+import Data.Text (Text)
+import System.Process (callCommand)
+
+import qualified Data.Sequence as Seq
+import qualified Data.Text as T
+
+import Monomer.Widgets.Container
+import Monomer.Widgets.Singles.Label
+
+import qualified Monomer.Lens as L
+
+data ExternalLinkCfg s e = ExternalLinkCfg {
+  _elcTextTrim :: Maybe Bool,
+  _elcTextEllipsis :: Maybe Bool,
+  _elcTextMultiLine :: Maybe Bool,
+  _elcTextMaxLines :: Maybe Int,
+  _elcFactorW :: Maybe Double,
+  _elcFactorH :: Maybe Double,
+  _elcOnFocus :: [e],
+  _elcOnFocusReq :: [WidgetRequest s e],
+  _elcOnBlur :: [e],
+  _elcOnBlurReq :: [WidgetRequest s e]
+}
+
+instance Default (ExternalLinkCfg s e) where
+  def = ExternalLinkCfg {
+    _elcTextTrim = Nothing,
+    _elcTextEllipsis = Nothing,
+    _elcTextMultiLine = Nothing,
+    _elcTextMaxLines = Nothing,
+    _elcFactorW = Nothing,
+    _elcFactorH = Nothing,
+    _elcOnFocus = [],
+    _elcOnFocusReq = [],
+    _elcOnBlur = [],
+    _elcOnBlurReq = []
+  }
+
+instance Semigroup (ExternalLinkCfg s e) where
+  (<>) t1 t2 = ExternalLinkCfg {
+    _elcTextTrim = _elcTextTrim t2 <|> _elcTextTrim t1,
+    _elcTextEllipsis = _elcTextEllipsis t2 <|> _elcTextEllipsis t1,
+    _elcTextMultiLine = _elcTextMultiLine t2 <|> _elcTextMultiLine t1,
+    _elcTextMaxLines = _elcTextMaxLines t2 <|> _elcTextMaxLines t1,
+    _elcFactorW = _elcFactorW t2 <|> _elcFactorW t1,
+    _elcFactorH = _elcFactorH t2 <|> _elcFactorH t1,
+    _elcOnFocus = _elcOnFocus t1 <> _elcOnFocus t2,
+    _elcOnFocusReq = _elcOnFocusReq t1 <> _elcOnFocusReq t2,
+    _elcOnBlur = _elcOnBlur t1 <> _elcOnBlur t2,
+    _elcOnBlurReq = _elcOnBlurReq t1 <> _elcOnBlurReq t2
+  }
+
+instance Monoid (ExternalLinkCfg s e) where
+  mempty = def
+
+instance CmbTrimSpaces (ExternalLinkCfg s e) where
+  trimSpaces_ trim = def {
+    _elcTextTrim = Just trim
+  }
+
+instance CmbEllipsis (ExternalLinkCfg s e) where
+  ellipsis_ ellipsis = def {
+    _elcTextEllipsis = Just ellipsis
+  }
+
+instance CmbMultiLine (ExternalLinkCfg s e) where
+  multiLine_ multi = def {
+    _elcTextMultiLine = Just multi
+  }
+
+instance CmbMaxLines (ExternalLinkCfg s e) where
+  maxLines count = def {
+    _elcTextMaxLines = Just count
+  }
+
+instance CmbOnFocus (ExternalLinkCfg s e) e where
+  onFocus fn = def {
+    _elcOnFocus = [fn]
+  }
+
+instance CmbOnFocusReq (ExternalLinkCfg s e) s e where
+  onFocusReq req = def {
+    _elcOnFocusReq = [req]
+  }
+
+instance CmbOnBlur (ExternalLinkCfg s e) e where
+  onBlur fn = def {
+    _elcOnBlur = [fn]
+  }
+
+instance CmbOnBlurReq (ExternalLinkCfg s e) s e where
+  onBlurReq req = def {
+    _elcOnBlurReq = [req]
+  }
+
+instance CmbResizeFactor (ExternalLinkCfg s e) where
+  resizeFactor s = def {
+    _elcFactorW = Just s,
+    _elcFactorH = Just s
+  }
+
+instance CmbResizeFactorDim (ExternalLinkCfg s e) where
+  resizeFactorW w = def {
+    _elcFactorW = Just w
+  }
+  resizeFactorH h = def {
+    _elcFactorH = Just h
+  }
+
+externalLink :: WidgetEvent e => Text -> Text -> WidgetNode s e
+externalLink caption url = externalLink_ caption url def
+
+externalLink_
+  :: WidgetEvent e => Text -> Text -> [ExternalLinkCfg s e] -> WidgetNode s e
+externalLink_ caption url configs = externalLinkNode where
+  config = mconcat configs
+  widget = makeExternalLink caption url config
+  externalLinkNode = defaultWidgetNode "externalLink" widget
+    & L.info . L.focusable .~ True
+
+makeExternalLink
+  :: WidgetEvent e => Text -> Text -> ExternalLinkCfg s e -> Widget s e
+makeExternalLink caption url config = widget where
+  widget = createContainer () def {
+    containerUseScissor = True,
+    containerGetBaseStyle = getBaseStyle,
+    containerInit = init,
+    containerMerge = merge,
+    containerHandleEvent = handleEvent,
+    containerGetSizeReq = getSizeReq,
+    containerResize = resize
+  }
+
+  trim = _elcTextTrim config == Just True
+  ellipsis = _elcTextEllipsis config == Just True
+  multiLine = _elcTextMultiLine config == Just True
+  maxLinesV = _elcTextMaxLines config
+  factorW = _elcFactorW config
+  factorH = _elcFactorH config
+
+  getBaseStyle wenv node = Just style where
+    style = collectTheme wenv L.externalLinkStyle
+
+  createChildNode wenv node = newNode where
+    nodeStyle = node ^. L.info . L.style
+    labelStyle = collectStyleField_ L.text nodeStyle def
+      & collectStyleField_ L.sizeReqW nodeStyle
+      & collectStyleField_ L.sizeReqH nodeStyle
+    cfgs = [
+      ignoreTheme,
+      trimSpaces_ trim,
+      ellipsis_ ellipsis,
+      multiLine_ multiLine]
+      ++ [maxLines (fromJust maxLinesV) | isJust maxLinesV]
+      ++ [resizeFactorW (fromJust factorW) | isJust factorW]
+      ++ [resizeFactorH (fromJust factorH) | isJust factorH]
+    labelNode = label_ caption cfgs
+      & L.info . L.style .~ labelStyle
+    childNode = labelNode
+    newNode = node
+      & L.children .~ Seq.singleton childNode
+
+  init wenv node = result where
+    result = resultWidget (createChildNode wenv node)
+
+  merge wenv node oldNode oldState = result where
+    result = resultWidget (createChildNode wenv node)
+
+  handleEvent wenv node target evt = case evt of
+    Focus -> handleFocusChange _elcOnFocus _elcOnFocusReq config node
+    Blur -> handleFocusChange _elcOnBlur _elcOnBlurReq config node
+    KeyAction mode code status
+      | isSelectKey code && status == KeyPressed -> Just result
+      where
+        isSelectKey code = isKeyReturn code || isKeySpace code
+    Click p _
+      | isPointInNodeVp p node -> Just result
+    -- Set focus on click
+    ButtonAction p btn PressedBtn 1
+      | mainBtn btn && pointInVp p && not focused -> Just resultFocus
+    ButtonAction p btn ReleasedBtn clicks
+      | mainBtn btn && focused && pointInVp p && clicks > 1 -> Just result
+    _ -> Nothing
+    where
+      widgetId = node ^. L.info . L.widgetId
+      path = node ^. L.info . L.path
+      mainBtn btn = btn == wenv ^. L.mainButton
+      focused = isNodeFocused wenv node
+      pointInVp p = isPointInNodeVp p node
+      openLinkTask = openLink wenv (T.unpack url)
+      requests = [RunTask widgetId path openLinkTask]
+      result = resultReqs node requests
+      resultFocus = resultReqs node [SetFocus (node ^. L.info . L.widgetId)]
+
+  getSizeReq :: ContainerGetSizeReqHandler s e
+  getSizeReq wenv node children = (newReqW, newReqH) where
+    -- Main section reqs
+    child = Seq.index children 0
+    newReqW = child ^. L.info . L.sizeReqW
+    newReqH = child ^. L.info . L.sizeReqH
+
+  resize wenv node viewport children = resized where
+    assignedAreas = Seq.fromList [viewport]
+    resized = (resultWidget node, assignedAreas)
+
+openLink :: WidgetEnv s e -> String -> IO ()
+openLink wenv url = catchIgnore (callCommand openCommand) where
+  os = wenv ^. L.os
+  command
+    | os == "Windows" = "start"
+    | os == "Mac OS X" = "open"
+    | os == "Linux" = "xdg-open"
+    | otherwise = "ls"
+  openCommand = command ++ " \"" ++ url ++ "\""
+
+catchIgnore :: IO () -> IO ()
+catchIgnore task = catchAny task (const $ return ())
+
+catchAny :: IO a -> (SomeException -> IO a) -> IO a
+catchAny = catch

test/unit/Monomer/TestUtil.hs

@@ -83,6 +83,9 @@ mockRenderer = Renderer {
   -- Overlays
   createOverlay  = \overlay -> return (),
   renderOverlays = return (),
+  -- Raw overlays
+  createRawOverlay  = \overlay -> return (),
+  renderRawOverlays = return (),
   -- Scissor operations
   intersectScissor = \rect -> return (),
   -- Translation
@@ -126,7 +129,7 @@ mockRenderer = Renderer {
 
 mockWenv :: s -> WidgetEnv s e
 mockWenv model = WidgetEnv {
-  _weOS = "Mac OS X",
+  _weOs = "Mac OS X",
   _weRenderer = mockRenderer,
   _weFindByPath = const Nothing,
   _weMainButton = LeftBtn,