mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-11 20:07:26 +03:00
Add initial external link widget
This commit is contained in:
parent
1b5988000b
commit
0c6d3f67a8
@ -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],
|
||||
|
@ -40,6 +40,7 @@ dependencies:
|
||||
- mtl
|
||||
- nanovg
|
||||
- OpenGL
|
||||
- process
|
||||
- safe
|
||||
- sdl2
|
||||
- stm
|
||||
|
@ -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,
|
||||
|
@ -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
|
||||
|
@ -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,
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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,
|
||||
|
@ -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
|
||||
|
@ -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,
|
||||
|
@ -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],
|
||||
|
234
src/Monomer/Widgets/Singles/ExternalLink.hs
Normal file
234
src/Monomer/Widgets/Singles/ExternalLink.hs
Normal file
@ -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
|
@ -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,
|
||||
|
Loading…
Reference in New Issue
Block a user