Fix style merge order issue, improve cursor handling (pending things)

2024-09-20 16:27:49 +03:00 · 2020-11-09 18:21:27 -03:00 · 2020-11-09 18:21:27 -03:00 · 0d305600c5
commit 0d305600c5
parent 0fbbb3d2f2
9 changed files with 131 additions and 108 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@ -112,18 +112,27 @@ buildUI model = trace "Creating UI" widgetTree4 where
      ] [ignoreEmptyClick True]
    ] [onlyTopActive False]
  widgetTree4 = hgrid [
+      label "" `style` [bgColor blue],
+      label "" `style` [bgColor gray],
+      label "" `style` [bgColor blue],
+      label "" `style` [bgColor orange],
      vstack [
        label "1" `style` [bgColor pink, border 1 pink],
-        label "2" `style` [bgColor gray, border 1 gray],
-        textDropdown_ textField1 items id [onChange DropdownVal, onChangeIdx DropdownIdx],
+        textField textField1 `style` [bgColor gray],
+        label "2" `style` [bgColor pink, border 1 gray],
+        textField textField1 `style` [textCenter, bgColor gray],
        label "3" `style` [bgColor pink],
-        textField textField1 `style` [textRight, bgColor gray]
+        textField textField1 `style` [textRight, bgColor gray],
+        label "4" `style` [bgColor pink]
      ],
      vstack [
-        textField textField1 `style` [bgColor gray],
+        --textDropdown_ textField1 items id [onChange DropdownVal, onChangeIdx DropdownIdx],
        label "1" `style` [bgColor pink, border 1 pink]
-      ],
-      label ""
+      ] `visible` False,
+      label "" `style` [bgColor orange],
+      label "" `style` [bgColor gray],
+      label "" `style` [bgColor blue],
+      label "" `style` [bgColor gray]
    ]
  widgetTree3 = hgrid [
      label "Hi!\nThis\nis\na\nnew\ttest\n\n  Double!" `style` [bgColor pink, textBottom, textCenter],
--- a/src/Monomer/Graphics/NanoVGRenderer.hs
+++ b/src/Monomer/Graphics/NanoVGRenderer.hs
@ -4,7 +4,7 @@

 module Monomer.Graphics.NanoVGRenderer (makeRenderer) where

-import Control.Monad (foldM, unless, when)
+import Control.Monad (foldM, forM_, unless, when)
 import Data.IORef
 import Data.List (foldl')
 import Data.Maybe
@ -91,8 +91,6 @@ makeRenderer fonts dpr = do

 newRenderer :: VG.Context -> Double -> L.Lock -> IORef Env -> Renderer
 newRenderer c dpr lock envRef = Renderer {..} where
-  defaultDpr = 1
-
  beginFrame w h = L.with lock $ do
    env <- readIORef envRef
    newMap <- handlePendingImages c (imagesMap env) (addedImages env)
@ -235,24 +233,24 @@ newRenderer c dpr lock envRef = Renderer {..} where
      ry = h / 2

  -- Text
-  computeTextMetrics font fontSize = unsafePerformIO $ do
-    setFont c envRef defaultDpr font fontSize
+  computeTextMetrics !font !fontSize = unsafePerformIO $ do
+    setFont c envRef dpr font fontSize
    (asc, desc, lineh) <- getTextMetrics c

    return $ TextMetrics {
-      _txmAsc = asc,
-      _txmDesc = desc,
-      _txmLineH = lineh
+      _txmAsc = asc / dpr,
+      _txmDesc = desc / dpr,
+      _txmLineH = lineh / dpr
    }

-  computeTextSize font fontSize text = unsafePerformIO $ do
+  computeTextSize !font !fontSize !text = unsafePerformIO $ do
    setFont c envRef dpr font fontSize
    (x1, y1, x2, y2) <- getTextBounds c 0 0 text

    return $ Size (realToFrac (x2 - x1) / dpr) (realToFrac (y2 - y1) / dpr)

  computeGlyphsPos :: Font -> FontSize -> Text -> Seq GlyphPos
-  computeGlyphsPos font fontSize message = unsafePerformIO $ do
+  computeGlyphsPos !font !fontSize !message = unsafePerformIO $ do
    -- Glyph position is usually used in local coord calculations, ignoring dpr
    setFont c envRef dpr font fontSize

--- a/src/Monomer/Graphics/Types.hs
+++ b/src/Monomer/Graphics/Types.hs
@ -16,18 +16,18 @@ data Winding
  deriving (Eq, Show)

 data Color = Color {
-  _colorR :: Int,
-  _colorG :: Int,
-  _colorB :: Int,
-  _colorA :: Double
+  _colorR :: !Int,
+  _colorG :: !Int,
+  _colorB :: !Int,
+  _colorA :: !Double
 } deriving (Show, Eq)

 instance Default Color where
  def = Color 255 255 255 1.0

 data FontDef = FontDef {
-  _fntName :: Text,
-  _fntPath :: Text
+  _fntName :: !Text,
+  _fntPath :: !Text
 }

 newtype Font
@ -70,10 +70,10 @@ instance Default AlignV where
  def = AMiddle

 data GlyphPos = GlyphPos {
-  _glpGlyph :: Char,
-  _glpXMin :: Double,
-  _glpXMax :: Double,
-  _glpW :: Double
+  _glpGlyph :: !Char,
+  _glpXMin :: !Double,
+  _glpXMax :: !Double,
+  _glpW :: !Double
 } deriving (Eq, Show)

 instance Default GlyphPos where
@ -85,9 +85,9 @@ instance Default GlyphPos where
  }

 data TextMetrics = TextMetrics {
-  _txmAsc :: Double,
-  _txmDesc :: Double,
-  _txmLineH :: Double
+  _txmAsc :: !Double,
+  _txmDesc :: !Double,
+  _txmLineH :: !Double
 } deriving (Eq, Show)

 instance Default TextMetrics where
--- a/src/Monomer/Widgets/Composite.hs
+++ b/src/Monomer/Widgets/Composite.hs
@ -117,8 +117,9 @@ compositeInit comp state wenv widgetComp = newResult where
    _cmpGlobalKeys = collectGlobalKeys M.empty root
  }
  tempResult = WidgetResult reqs newEvts root
-  result = reduceResult comp newState wenv widgetComp tempResult
-  newResult = baseStyleToResult wenv Nothing result
+  styledComp = initInstanceStyle wenv Nothing widgetComp
+  newResult = reduceResult comp newState wenv styledComp tempResult
+

 -- | Merge
 compositeMerge
@ -147,8 +148,8 @@ compositeMerge comp state wenv oldComposite newComposite = newResult where
    _cmpRoot = newRoot,
    _cmpGlobalKeys = collectGlobalKeys M.empty newRoot
  }
-  result = reduceResult comp newState wenv newComposite tempResult
-  newResult = baseStyleToResult wenv Nothing result
+  styledComp = initInstanceStyle wenv Nothing newComposite
+  newResult = reduceResult comp newState wenv styledComp tempResult

 -- | Dispose
 compositeDispose
--- a/src/Monomer/Widgets/Container.hs
+++ b/src/Monomer/Widgets/Container.hs
@ -209,9 +209,9 @@ initWrapper initHandler getBaseStyle wenv inst = newResult where
  newInstance = tempInstance {
    _wiChildren = newChildren
  }
-  result = WidgetResult (reqs <> newReqs) (events <> newEvents) newInstance
  baseStyle = getBaseStyle wenv newInstance
-  newResult = baseStyleToResult wenv baseStyle result
+  styledInst = initInstanceStyle wenv baseStyle newInstance
+  newResult = WidgetResult (reqs <> newReqs) (events <> newEvents) styledInst

 -- | Merging
 defaultMerge :: ContainerMergeHandler s e
@ -247,9 +247,9 @@ mergeWrapper mergeHandler getBaseStyle wenv oldInst newInst = newResult where
  }
  newReqs = uReqs <> mergedReqs <> removedReqs
  newEvents = uEvents <> mergedEvents <> removedEvents
-  result = WidgetResult newReqs newEvents mergedInstance
  baseStyle = getBaseStyle wenv uInstance
-  newResult = baseStyleToResult wenv baseStyle result
+  styledInst = initInstanceStyle wenv baseStyle mergedInstance
+  newResult = WidgetResult newReqs newEvents styledInst

 mergeChildren
  :: WidgetEnv s e
@ -386,16 +386,15 @@ handleEventWrapper
  -> Maybe (WidgetResult s e)
 handleEventWrapper styleOnMerge pHandler wenv target event inst
  | not (_wiVisible inst) = Nothing
-  | targetReached = handleStyleChange pHandler wenv target event inst
-  | not targetValid = Nothing -- `not targetValid` applies to children only
-  | styleOnMerge = handleStyleChange sHandler wenv target event inst
-  | otherwise = mergeParentChildEvts inst pResponse cResponse childIdx
+--  | not targetValid = Nothing
+  | targetReached || not targetValid = parentResult
+  | styleOnMerge = styledChildrenResult
+  | otherwise = childrenResult
  where
    -- Having targetValid = False means the next path step is not in
    -- _wiChildren, but may still be valid in the receiving widget
    -- For example, Composite has its own tree of child widgets with (possibly)
    -- different types for Model and Events, and is candidate for the next step
-    sHandler _ _ _ _ = mergeParentChildEvts inst pResponse cResponse childIdx
    targetReached = isTargetReached target inst
    targetValid = isTargetValid target inst
    childIdx = fromJust $ nextTargetStep target inst
@ -407,6 +406,10 @@ handleEventWrapper styleOnMerge pHandler wenv target event inst
    cResponse
      | childrenIgnored || not (_wiEnabled child) = Nothing
      | otherwise = widgetHandleEvent childWidget wenv target event child
+    sHandler _ _ _ _ = mergeParentChildEvts inst pResponse cResponse childIdx
+    parentResult = handleStyleChange pHandler wenv target event inst
+    childrenResult = mergeParentChildEvts inst pResponse cResponse childIdx
+    styledChildrenResult = handleStyleChange sHandler wenv target event inst

 mergeParentChildEvts
  :: WidgetInstance s e
--- a/src/Monomer/Widgets/InputField.hs
+++ b/src/Monomer/Widgets/InputField.hs
@ -58,7 +58,7 @@ inputFieldState = InputFieldState {
 }

 caretWidth :: Double
-caretWidth = 2
+caretWidth = 1

 inputField_
  :: (Eq a, Default a, Typeable a)
@ -124,12 +124,12 @@ makeInputField config state = widget where
      | otherwise = oldText
    newTextL = T.length newText
    newPos
-      | newTextL < oldPos = T.length newText
+      | newTextL < oldPos = newTextL
      | otherwise = oldPos
    newSelStart
      | isNothing oldSel || newTextL < fromJust oldSel = Nothing
      | otherwise = oldSel
-    newState = newTextState wenv inst state value newText newPos newSelStart
+    newState = newTextState wenv inst oldTextState value newText newPos newSelStart
    newInstance = inst {
      _wiWidget = makeInputField config newState
    }
@ -137,21 +137,22 @@ makeInputField config state = widget where
    reqs = setModelValid (isJust parsedVal)

  handleKeyPress wenv mod code
-    | isBackspace && isNothing currSel = moveCursor removeText (tp - 1) Nothing
-    | isBackspace = moveCursor removeText (min currSelVal tp) Nothing
-    | isMoveLeft = moveCursor txt (tp - 1) Nothing
-    | isMoveRight = moveCursor txt (tp + 1) Nothing
-    | isMoveWordL = moveCursor txt prevWordStartIdx Nothing
-    | isMoveWordR = moveCursor txt nextWordEndIdx Nothing
-    | isSelectLeft = moveCursor txt (tp - 1) (Just tp)
-    | isSelectRight = moveCursor txt (tp + 1) (Just tp)
-    | isSelectWordL = moveCursor txt prevWordStartIdx (Just tp)
-    | isSelectWordR = moveCursor txt nextWordEndIdx (Just tp)
-    | otherwise = moveCursor txt tp currSel
+    | isBackspace && emptySel = Just $ moveCursor removeText (tp - 1) Nothing
+    | isBackspace = Just $ moveCursor removeText (min currSelVal tp) Nothing
+    | isMoveLeft = Just $ moveCursor txt (tp - 1) Nothing
+    | isMoveRight = Just $ moveCursor txt (tp + 1) Nothing
+    | isMoveWordL = Just $ moveCursor txt prevWordStartIdx Nothing
+    | isMoveWordR = Just $ moveCursor txt nextWordEndIdx Nothing
+    | isSelectLeft = Just $ moveCursor txt (tp - 1) (Just tp)
+    | isSelectRight = Just $ moveCursor txt (tp + 1) (Just tp)
+    | isSelectWordL = Just $ moveCursor txt prevWordStartIdx (Just tp)
+    | isSelectWordR = Just $ moveCursor txt nextWordEndIdx (Just tp)
+    | otherwise = Nothing
    where
      txt = currText
      txtLen = T.length txt
      tp = currPos
+      emptySel = isNothing currSel
      (part1, part2) = T.splitAt currPos currText
      prevWordStart = T.dropWhileEnd (not . delim) $ T.dropWhileEnd delim part1
      prevWordStartIdx = T.length prevWordStart
@ -161,7 +162,7 @@ makeInputField config state = widget where
      isWordMod
        | isMacOS wenv = _kmLeftAlt mod
        | otherwise = _kmLeftCtrl mod
-      isBackspace = isKeyBackspace code && tp > 0
+      isBackspace = isKeyBackspace code && (tp > 0 || isJust currSel)
      isMove = not isShift && not isWordMod
      isMoveWord = not isShift && isWordMod
      isSelect = isShift && not isWordMod
@ -215,14 +216,15 @@ makeInputField config state = widget where
        | isFocused wenv inst = Just $ resultWidget newInst
        | otherwise = Just $ resultReqs [SetFocus $ _wiPath inst] newInst

-    KeyAction mod code KeyPressed -> Just result where
-      (newText, newPos, newSel) = handleKeyPress wenv mod code
-      isPaste = isClipboardPaste wenv evt
-      isCopy = isClipboardCopy wenv evt
-      reqGetClipboard = [GetClipboard (_wiPath inst) | isPaste]
-      reqSetClipboard = [SetClipboard (ClipboardText copyText) | isCopy]
-      reqs = reqGetClipboard ++ reqSetClipboard
-      result = genInputResult wenv inst False newText newPos newSel reqs
+    KeyAction mod code KeyPressed -> result where
+      result = handleKeyRes <$> handleKeyPress wenv mod code
+      handleKeyRes (newText, newPos, newSel) = result where
+        isPaste = isClipboardPaste wenv evt
+        isCopy = isClipboardCopy wenv evt
+        reqGetClipboard = [GetClipboard (_wiPath inst) | isPaste]
+        reqSetClipboard = [SetClipboard (ClipboardText copyText) | isCopy]
+        reqs = reqGetClipboard ++ reqSetClipboard
+        result = genInputResult wenv inst False newText newPos newSel reqs

    TextInput newText -> insertText wenv inst newText

@ -244,12 +246,27 @@ makeInputField config state = widget where
    _ -> Nothing

  insertText wenv inst addedText = Just result where
+    addedLen = T.length addedText
    newText = replaceText currText addedText
    newPos
-      | isJust currSel = 1 + min currPos (fromJust currSel)
-      | otherwise = currPos + T.length addedText
+      | isJust currSel = addedLen + min currPos (fromJust currSel)
+      | otherwise = addedLen + currPos
    result = genInputResult wenv inst True newText newPos Nothing []

+  replaceText txt newTxt
+    | isJust currSel = T.take start txt <> newTxt <> T.drop end txt
+    | otherwise = T.take currPos txt <> newTxt <> T.drop currPos txt
+    where
+      start = min currPos (fromJust currSel)
+      end = max currPos (fromJust currSel)
+
+  copyText
+    | isJust currSel = T.take (end - start) $ T.drop start currText
+    | otherwise = ""
+    where
+      start = min currPos (fromJust currSel)
+      end = max currPos (fromJust currSel)
+
  genInputResult wenv inst textAdd newText newPos newSel newReqs = result where
    isValid = _ifcAcceptInput config newText
    hasChanged = currText /= newText
@ -277,20 +294,6 @@ makeInputField config state = widget where
      | isValid || not textAdd = resultReqsEvents reqs events newInstance
      | otherwise = resultReqsEvents reqs events inst

-  replaceText txt newTxt
-    | isJust currSel = T.take start txt <> newTxt <> T.drop end txt
-    | otherwise = T.take currPos txt <> newTxt <> T.drop currPos txt
-    where
-      start = min currPos (fromJust currSel)
-      end = max currPos (fromJust currSel)
-
-  copyText
-    | isJust currSel = T.take (end - start) $ T.drop start currText
-    | otherwise = ""
-    where
-      start = min currPos (fromJust currSel)
-      end = max currPos (fromJust currSel)
-
  getSizeReq wenv inst = sizeReq where
    style = activeStyle wenv inst
    Size w h = getTextSize wenv style currText
@ -381,25 +384,33 @@ newTextState wenv inst oldState value text cursor selection = newState where
  alignH = fromMaybe ALeft (_txsAlignH textStyle)
  alignV = fromMaybe def (_txsAlignV textStyle)
  align = Align alignH alignV
+  alignL = alignH == ALeft
+  alignR = alignH == ARight
+  alignC = alignH == ACenter
+  cursorL = cursor == 0
+  cursorR = cursor == T.length text
  !textMetrics = getTextMetrics wenv style
-  !tempTextRect = getTextRect wenv style contentArea align text
-  textRect
-    | alignH == ARight = moveRect (Point (-caretWidth) 0) tempTextRect
-    | otherwise = tempTextRect
-  TextMetrics ta ts tl = textMetrics
-  Rect tx ty tw th = textRect
-  glyphs = getTextGlyphs wenv style text
-  g :<| gs = glyphs
-  glyphX = maybe 0 _glpXMax $ Seq.lookup (cursor - 1) glyphs
-  glyphOffset = getGlyphsMin glyphs
-  curX = tx + glyphX - glyphOffset
-  oldOffset = _ifsOffset oldState
+  !textRect = getTextRect wenv style contentArea align text
+  Rect _ _ tw th = textRect
  textFits = cw >= tw
+  TextMetrics ta ts tl = textMetrics
+  Rect tx ty _ _ = textRect
+  glyphs = getTextGlyphs wenv style text
+  glyphStart = maybe 0 _glpXMax $ Seq.lookup (cursor - 1) glyphs
+  glyphOffset = getGlyphsMin glyphs
+  glyphX = glyphStart - glyphOffset
+  curX = tx + glyphX
+  oldOffset = _ifsOffset oldState
  newOffset
    | textFits = 0
-    | cursor == 0 && not textFits = cx - tx
-    | curX + oldOffset > cx + cw = cx + cw - curX
-    | curX + oldOffset < cx = cx - curX
+    | alignL && cursorL = cx - tx + caretWidth
+    | alignL && curX + oldOffset > cx + cw = cx + cw - curX
+    | alignL && curX + oldOffset < cx = cx - curX
+    | alignR && cursorR = 0
+    | alignR && curX + oldOffset > cx + cw = tw - glyphX
+    | alignR && curX + oldOffset < cx = tw - cw - glyphX
+    | alignC && curX + oldOffset > cx + cw = cx + cw - curX
+    | alignC && curX + oldOffset < cx = cx - curX
    | otherwise = oldOffset
  newState = InputFieldState {
    _ifsCurrValue = value,
--- a/src/Monomer/Widgets/Single.hs
+++ b/src/Monomer/Widgets/Single.hs
@ -152,8 +152,8 @@ initWrapper
  -> WidgetResult s e
 initWrapper initHandler getBaseStyle wenv inst = newResult where
  baseStyle = getBaseStyle wenv inst
-  tempResult = initHandler wenv inst
-  newResult = baseStyleToResult wenv baseStyle tempResult
+  styledInst = initInstanceStyle wenv baseStyle inst
+  newResult = initHandler wenv styledInst

 defaultMerge :: SingleMergeHandler s e
 defaultMerge wenv oldState newInst = resultWidget newInst
@ -172,8 +172,8 @@ mergeWrapper mergeHandler getBaseStyle wenv oldInst newInst = newResult where
    _wiRenderArea = _wiRenderArea oldInst
  }
  baseStyle = getBaseStyle wenv tempInst
-  tempResult = mergeHandler wenv oldState tempInst
-  newResult = baseStyleToResult wenv baseStyle tempResult
+  styledInst = initInstanceStyle wenv baseStyle tempInst
+  newResult = mergeHandler wenv oldState styledInst

 defaultDispose :: SingleDisposeHandler s e
 defaultDispose _ inst = resultWidget inst
--- a/src/Monomer/Widgets/Util/Base.hs
+++ b/src/Monomer/Widgets/Util/Base.hs
@ -1,5 +1,5 @@
 module Monomer.Widgets.Util.Base (
-  baseStyleToResult,
+  initInstanceStyle,
  handleSizeReqStyle,
  handleStyleChange,
  isFixedSizeReq,
@ -45,20 +45,18 @@ baseStyleFromTheme theme = style where
    _sstText = Just $ _thsText tstate
  }

-baseStyleToResult
+initInstanceStyle
  :: WidgetEnv s e
  -> Maybe Style
-  -> WidgetResult s e
-  -> WidgetResult s e
-baseStyleToResult wenv mbaseStyle result = newResult where
+  -> WidgetInstance s e
+  -> WidgetInstance s e
+initInstanceStyle wenv mbaseStyle inst = newInst where
  instStyle = mergeBasicStyle $ _wiStyle inst
  baseStyle = mergeBasicStyle $ fromMaybe def mbaseStyle
  themeStyle = baseStyleFromTheme (_weTheme wenv)
-  WidgetResult reqs evts inst = result
  newInst = inst {
    _wiStyle = themeStyle <> baseStyle <> instStyle
  }
-  newResult = WidgetResult reqs evts newInst

 mergeBasicStyle :: Style -> Style
 mergeBasicStyle st = newStyle where
--- a/tasks.md
+++ b/tasks.md
@ -258,7 +258,10 @@
    - Check displaced textField when adding characters on right align
      - Also, when right is reached from left, everything is pushed out of screen
    - Double clicking on empty puts the cursor at the end of ghost character
-    - Right aligned version has cusor overlaid
+    - Right aligned version has cusor overlaid (add caret size to offset in specific cases)
+    - Make left added char visible
+    - Check clipboard
+  - Check Container thing in hover adding columns (not targetValid = Nothing should be removed)
  - Add testing
    - Delayed until this point to try to settle down interfaces
    - Validate stack assigns space correctly