Add mouse selection to text field

app/Main.hs

@@ -109,10 +109,16 @@ handleAppEvent wenv model evt = case evt of
 buildUI :: WidgetEnv App AppEvent -> App -> WidgetNode App AppEvent
 buildUI wenv model = trace "Creating UI" widgetInput where
   widgetInput = vstack [
-      hstack [
+      hgrid [
         label "Username: ",
-        textField textField1
-      ] `style` [padding 5]
+        textField textField1,
+        label ""
+      ] `style` [padding 5],
+      hgrid [
+        label "Password: ",
+        textField textField2,
+        label ""
+      ] `style` [padding 5, paddingT 0]
     ]
   widgetLV = vstack [
 --      scroll $ vstack $ (\i -> box $ label ("Label: " <> showt i)) <$> [0..1000::Int]

app/Types.hs

@@ -25,6 +25,7 @@ data App = App {
   _float1 :: Double,
   _validFloat1 :: Bool,
   _textField1 :: Text,
+  _textField2 :: Text,
   _dropdown1 :: Text,
   _fruit :: Fruit,
   _condition1 :: Bool,
@@ -44,7 +45,8 @@ instance Default App where
     _validInteger1 = True,
     _float1 = 0,
     _validFloat1 = True,
-    _textField1 = "",
+    _textField1 = "This is a long piece of text used to test mouse selection",
+    _textField2 = "",
     _dropdown1 = "",
     _fruit = Orange,
     _condition1 = False,

src/Monomer/Core/WidgetTypes.hs

@@ -107,8 +107,8 @@ data WidgetEnv s e = WidgetEnv {
   _weWindowSize :: Size,
   _weGlobalKeys :: GlobalKeys s e,
   _weFocusedPath :: Path,
-  _wePressedPath :: Maybe Path,
   _weOverlayPath :: Maybe Path,
+  _weMainBtnPress :: Maybe (Path, Point),
   _weCurrentCursor :: CursorIcon,
   _weModel :: s,
   _weInputStatus :: InputStatus,

src/Monomer/Main/Core.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -121,7 +122,7 @@ runApp window widgetRoot config = do
     _weCurrentCursor = CursorArrow,
     _weFocusedPath = rootPath,
     _weOverlayPath = Nothing,
-    _wePressedPath = Nothing,
+    _weMainBtnPress = Nothing,
     _weModel = model,
     _weInputStatus = def,
     _weTimestamp = startTs,
@@ -168,7 +169,7 @@ mainLoop window renderer config loopArgs = do
   currentCursor <- use currentCursor
   focused <- use focusedPath
   overlay <- use overlayPath
-  pressed <- use pressedPath
+  mainPress <- use mainBtnPress
 
   let MainLoopArgs{..} = loopArgs
   let !ts = startTicks - _mlFrameStartTs
@@ -180,7 +181,6 @@ mainLoop window renderer config loopArgs = do
   let mousePixelRate = if not useHiDPI then devicePixelRate else 1
   let baseSystemEvents = convertEvents mousePixelRate mousePos eventsPayload
   let newSecond = _mlFrameAccumTs > 1000
-  let isMouseFocused = isJust pressed
 
   inputStatus <- updateInputStatus baseSystemEvents
 
@@ -198,7 +198,7 @@ mainLoop window renderer config loopArgs = do
     _weCurrentCursor = currentCursor,
     _weFocusedPath = focused,
     _weOverlayPath = overlay,
-    _wePressedPath = pressed,
+    _weMainBtnPress = mainPress,
     _weModel = currentModel,
     _weInputStatus = inputStatus,
     _weTimestamp = startTicks,
@@ -215,8 +215,8 @@ mainLoop window renderer config loopArgs = do
   let baseReqs = Seq.fromList [ exitMsg | quit ]
   let baseStep = (wenv, Seq.empty, _mlWidgetRoot)
 
-  when (mouseEntered && isMainBtnPressed && isMouseFocused) $
-    pressedPath .= Nothing
+  when (windowExposed && isMainBtnPressed) $
+    mainBtnPress .= Nothing
 
   (rqWenv, _, rqRoot) <- handleRequests baseReqs baseStep
   (wtWenv, _, wtRoot) <- handleWidgetTasks rqWenv rqRoot
@@ -340,19 +340,20 @@ preProcessEvent wenv mainBtn widgetRoot evt = case evt of
     let curr = widgetFindByPoint widget wenv startPath point widgetRoot
 
     when (btn == mainBtn) $
-      pressedPath .= curr
+      mainBtnPress .= fmap (, point) curr
 
     return [evt]
   ButtonAction point btn ReleasedBtn -> do
     overlay <- use L.overlayPath
-    pressed <- use pressedPath
+    mainPress <- use mainBtnPress
+    let pressed = fmap fst mainPress
     let startPath = fromMaybe rootPath overlay
     let widget = widgetRoot ^. L.widget
     let curr = widgetFindByPoint widget wenv startPath point widgetRoot
     let extraEvt = [Click point btn | btn == mainBtn && curr == pressed]
 
     when (btn == mainBtn) $
-      pressedPath .= Nothing
+      mainBtnPress .= Nothing
 
     return $ extraEvt ++ [evt]
   _ -> return [evt]

src/Monomer/Main/Handlers.hs

@@ -63,8 +63,9 @@ handleSystemEvent
   -> WidgetNode s e
   -> m (HandlerStep s e)
 handleSystemEvent wenv event currentTarget widgetRoot = do
-  pressed <- use L.pressedPath
+  mainStart <- use L.mainBtnPress
   overlay <- use L.overlayPath
+  let pressed = fmap fst mainStart
 
   case getTargetPath wenv pressed overlay currentTarget event widgetRoot of
     Nothing -> return (wenv, Seq.empty, widgetRoot)

src/Monomer/Main/Types.hs

@@ -48,8 +48,8 @@ data MonomerContext s = MonomerContext {
   _mcCurrentCursor :: CursorIcon,
   _mcFocusedPath :: Path,
   _mcHoveredPath :: Maybe Path,
-  _mcPressedPath :: Maybe Path,
   _mcOverlayPath :: Maybe Path,
+  _mcMainBtnPress :: Maybe (Path, Point),
   _mcWidgetTasks :: Seq WidgetTask,
   _mcCursorIcons :: Map CursorIcon SDLR.Cursor,
   _mcRenderRequested :: Bool,

src/Monomer/Main/Util.hs

@@ -33,8 +33,8 @@ initMonomerContext model win winSize useHiDPI devicePixelRate = MonomerContext {
   _mcCurrentCursor = CursorArrow,
   _mcFocusedPath = Seq.empty,
   _mcHoveredPath = Nothing,
-  _mcPressedPath = Nothing,
   _mcOverlayPath = Nothing,
+  _mcMainBtnPress = Nothing,
   _mcWidgetTasks = Seq.empty,
   _mcCursorIcons = Map.empty,
   _mcRenderRequested = False,

src/Monomer/Widgets/Composite.hs

@@ -685,7 +685,7 @@ convertWidgetEnv wenv globalKeys model = WidgetEnv {
   _weGlobalKeys = globalKeys,
   _weCurrentCursor = _weCurrentCursor wenv,
   _weFocusedPath = _weFocusedPath wenv,
-  _wePressedPath = _wePressedPath wenv,
+  _weMainBtnPress = _weMainBtnPress wenv,
   _weOverlayPath = _weOverlayPath wenv,
   _weModel = model,
   _weInputStatus = _weInputStatus wenv,

src/Monomer/Widgets/InputField.hs

@@ -8,6 +8,7 @@ module Monomer.Widgets.InputField (
   makeInputField
 ) where
 
+import Control.Applicative ((<|>))
 import Control.Monad
 import Control.Lens (ALens', (&), (.~), (%~), (^.), (^?), _Just, cloneLens, non)
 import Data.Default
@@ -268,25 +269,24 @@ makeInputField config state = widget where
         | otherwise = idx
 
   handleEvent wenv target evt node = case evt of
-    Click (Point x y) _ -> result where
-      style = activeStyle wenv node
-      contentArea = getContentArea style node
-      localX = x - _rX contentArea + _ifsOffset state
-      textLen = getGlyphsMax (_ifsGlyphs state)
-      glyphs
-        | Seq.null (_ifsGlyphs state) = Seq.empty
-        | otherwise = _ifsGlyphs state |> GlyphPos ' ' textLen 0 0
-      glyphStart i g = (i, abs (_glpXMin g - localX))
-      pairs = Seq.mapWithIndex glyphStart glyphs
-      cpm (_, g1) (_, g2) = compare g1 g2
-      diffs = Seq.sortBy cpm pairs
-      newPos = maybe 0 fst (Seq.lookup 0 diffs)
-      newState = newTextState wenv node state currVal currText newPos Nothing
-      newNode = node
-        & L.widget .~ makeInputField config newState
-      result
-        | isFocused wenv node = Just $ resultWidget newNode
-        | otherwise = Just $ resultReqs newNode [SetFocus path]
+    ButtonAction point btn PressedBtn
+      | wenv ^. L.mainButton == btn -> Just $ resultWidget newNode where
+        style = activeStyle wenv node
+        contentArea = getContentArea style node
+        newPos = findClosestGlyphPos state contentArea point
+        newState = newTextState wenv node state currVal currText newPos Nothing
+        newNode = node
+          & L.widget .~ makeInputField config newState
+
+    Move point
+      | isPressed wenv node -> Just $ resultReqs newNode [RenderOnce] where
+        style = activeStyle wenv node
+        contentArea = getContentArea style node
+        newPos = findClosestGlyphPos state contentArea point
+        newSel = currSel <|> Just currPos
+        newState = newTextState wenv node state currVal currText newPos newSel
+        newNode = node
+          & L.widget .~ makeInputField config newState
 
     KeyAction mod code KeyPressed
       | isKeyboardCopy wenv evt
@@ -519,6 +519,20 @@ moveHistory wenv node state config steps = result where
     }
     newNode = node & L.widget .~ makeInputField config newState
 
+findClosestGlyphPos :: InputFieldState a -> Rect -> Point -> Int
+findClosestGlyphPos state contentArea point = newPos where
+  Point x y = point
+  localX = x - _rX contentArea - _ifsOffset state
+  textLen = getGlyphsMax (_ifsGlyphs state)
+  glyphs
+    | Seq.null (_ifsGlyphs state) = Seq.empty
+    | otherwise = _ifsGlyphs state |> GlyphPos ' ' textLen 0 0
+  glyphStart i g = (i, abs (_glpXMin g - localX))
+  pairs = Seq.mapWithIndex glyphStart glyphs
+  cpm (_, g1) (_, g2) = compare g1 g2
+  diffs = Seq.sortBy cpm pairs
+  newPos = maybe 0 fst (Seq.lookup 0 diffs)
+
 newStateFromHistory
   :: (Eq a, Default a)
   => WidgetEnv s e
@@ -578,12 +592,17 @@ newTextState wenv node oldState value text cursor selection = newState where
     | alignC && curX + oldOffset > cx + cw = cx + cw - curX
     | alignC && curX + oldOffset < cx = cx - curX
     | otherwise = oldOffset
+  justSel = fromJust selection
+  newSel
+    | Just cursor == selection = Nothing
+    | isJust selection && justSel < 0 && justSel > T.length text = Nothing
+    | otherwise = selection
   newState = oldState {
     _ifsCurrValue = value,
     _ifsCurrText = text,
     _ifsGlyphs = glyphs,
     _ifsCursorPos = cursor,
-    _ifsSelStart = selection,
+    _ifsSelStart = newSel,
     _ifsOffset = newOffset,
     _ifsTextRect = textRect & L.x .~ tx + newOffset,
     _ifsTextMetrics = textMetrics

src/Monomer/Widgets/Util/Widget.hs

@@ -27,7 +27,7 @@ module Monomer.Widgets.Util.Widget (
 ) where
 
 import Control.Applicative ((<|>))
-import Control.Lens ((&), (^#), (#~), (^.), (.~), (%~))
+import Control.Lens ((&), (^#), (#~), (^.), (^?), (.~), (%~), _1, _Just)
 import Data.Default
 import Data.Foldable (foldl')
 import Data.Maybe
@@ -63,10 +63,9 @@ isWidgetVisible node vp = isVisible && isOverlapped where
   isOverlapped = rectsOverlap vp (info ^. L.viewport)
 
 isPressed :: WidgetEnv s e -> WidgetNode s e -> Bool
-isPressed wenv node = validPress where
+isPressed wenv node = Just path == pressed where
   path = node ^. L.info . L.path
-  pressed = wenv ^. L.pressedPath
-  validPress = isNothing pressed || Just path == pressed
+  pressed = wenv ^. L.mainBtnPress ^? _Just . _1
 
 isFocused :: WidgetEnv s e -> WidgetNode s e -> Bool
 isFocused wenv node = wenv ^. L.focusedPath == node ^. L.info . L.path
@@ -76,7 +75,8 @@ isHovered wenv node = validPos && validPress && isTopLevel wenv node where
   viewport = node ^. L.info . L.viewport
   mousePos = wenv ^. L.inputStatus . L.mousePos
   validPos = pointInRect mousePos viewport
-  validPress = isPressed wenv node
+  pressed = wenv ^. L.mainBtnPress ^? _Just . _1
+  validPress = isNothing pressed || isPressed wenv node
 
 visibleChildrenChanged :: WidgetNode s e -> WidgetNode s e -> Bool
 visibleChildrenChanged oldNode newNode = oldVisible /= newVisible  where