Handle textField overflow

app/Main.hs

@@ -155,7 +155,8 @@ buildUI model = trace "Creating UI" widgetTree where
       --  radio fruit Orange,
       --  radio fruit Pear
       --],
-      textField textField1 `style` bgColor lightGray <> height 200 <> textCenter,
+      textField textField1 `style` bgColor lightGray <> height 200 <> textLeft,
+      textField textField2,
       hstack [
         label "This is a long label",
         label "Another long label",

src/Monomer/Common/Geometry.hs

@@ -39,9 +39,13 @@ makeLensesWith abbreviatedFields ''Size
 makeLensesWith abbreviatedFields ''Rect
 
 pointInRect :: Point -> Rect -> Bool
-pointInRect (Point px py) (Rect x y w h) = pointInH && pointInV where
-  pointInH = px >= x && px < x + w
-  pointInV = py >= y && py < y + h
+pointInRect (Point px py) rect = coordInRectH px rect && coordInRectY py rect
+
+coordInRectH :: Double -> Rect -> Bool
+coordInRectH px (Rect x y w h) = px >= x && px < x + w
+
+coordInRectY :: Double -> Rect -> Bool
+coordInRectY py (Rect x y w h) = py >= y && py < y + h
 
 addToSize :: Size -> Double -> Double -> Size
 addToSize (Size w h) w2 h2 = Size nw nh where

src/Monomer/Common/StyleUtil.hs

@@ -4,7 +4,13 @@ module Monomer.Common.StyleUtil (
   addOuterBounds,
   removeOuterSize,
   removeOuterBounds,
-  subtractMargin
+  subtractMargin,
+  textStyle,
+  textFont,
+  textSize,
+  textColor,
+  textAlignH,
+  textAlignV
 ) where
 
 import Data.Default
@@ -12,6 +18,25 @@ import Data.Maybe
 
 import Monomer.Common.Geometry
 import Monomer.Common.Style
+import Monomer.Graphics.Types
+
+textStyle :: StyleState -> TextStyle
+textStyle sst = fromMaybe def (_sstText sst)
+
+textFont :: StyleState -> Font
+textFont style = fromMaybe def (_txsFont $ textStyle style)
+
+textSize :: StyleState -> FontSize
+textSize style = fromMaybe def (_txsFontSize $ textStyle style)
+
+textColor :: StyleState -> Color
+textColor style = fromMaybe def (_txsColor $ textStyle style)
+
+textAlignH :: StyleState -> AlignH
+textAlignH style = fromMaybe def (_txsAlignH $ textStyle style)
+
+textAlignV :: StyleState -> AlignV
+textAlignV style = fromMaybe def (_txsAlignV $ textStyle style)
 
 mergeThemeStyle :: ThemeState -> StyleState -> StyleState
 mergeThemeStyle theme style = newStyle where
@@ -20,9 +45,9 @@ mergeThemeStyle theme style = newStyle where
     _txsFontSize = Just $ _thsFontSize theme,
     _txsColor = Just $ _thsColor theme
   }
-  textFgColor = Just $ _thsFgColor theme
+  themeFgColor = Just $ _thsFgColor theme
   newStyle = style {
-    _sstFgColor = _sstFgColor style <> textFgColor,
+    _sstFgColor = _sstFgColor style <> themeFgColor,
     _sstText = _sstText style <> themeText
   }
 

src/Monomer/Graphics/Drawing.hs

@@ -10,6 +10,7 @@ module Monomer.Graphics.Drawing (
   drawStyledBackground,
   drawStyledText,
   drawStyledText_,
+  drawText,
   drawImage,
   drawStyledImage
 ) where
@@ -83,12 +84,32 @@ drawStyledBackground renderer viewport style =
 
 drawStyledText :: Renderer -> Rect -> StyleState -> Text -> IO Rect
 drawStyledText renderer viewport style txt = action where
-  action = drawText renderer viewport (_sstText style) txt
+  action = drawText renderer viewport tsColor tsFont tsFontSize tsAlign txt
+  TextStyle{..} = fromMaybe def (_sstText style)
+  tsColor = justDef _txsColor
+  tsFont = justDef _txsFont
+  tsFontSize = fromMaybe def _txsFontSize
+  tsAlignH = justDef _txsAlignH
+  tsAlignV = justDef _txsAlignV
+  tsAlign = Align tsAlignH tsAlignV
 
 drawStyledText_ :: Renderer -> Rect -> StyleState -> Text -> IO ()
 drawStyledText_ renderer viewport style txt = void action where
   action = drawStyledText renderer viewport style txt
 
+drawText
+  :: Renderer
+  -> Rect
+  -> Color
+  -> Font
+  -> FontSize
+  -> Align
+  -> Text
+  -> IO Rect
+drawText renderer viewport color font fontSize align txt = do
+    setFillColor renderer color
+    renderText renderer viewport font fontSize align txt
+
 drawImage :: Renderer -> Rect -> String -> IO ()
 drawImage renderer viewport imgName = action where
   action = renderImage renderer viewport imgName
@@ -315,20 +336,6 @@ strokeBorder renderer from to (Just BorderSide{..}) = do
   renderLineTo renderer to
   stroke renderer
 
-drawText :: Renderer -> Rect -> Maybe TextStyle -> Text -> IO Rect
-drawText renderer viewport Nothing txt =
-  drawText renderer viewport (Just mempty) txt
-drawText renderer viewport (Just TextStyle{..}) txt = do
-    setFillColor renderer tsColor
-    renderText renderer viewport tsFont tsFontSize tsAlign txt
-  where
-    tsColor = justDef _txsColor
-    tsFont = justDef _txsFont
-    tsFontSize = fromMaybe def _txsFontSize
-    tsAlignH = justDef _txsAlignH
-    tsAlignV = justDef _txsAlignV
-    tsAlign = Align tsAlignH tsAlignV
-
 justDef :: (Default a) => Maybe a -> a
 justDef val = fromMaybe def val
 

src/Monomer/Graphics/NanoVGRenderer.hs

@@ -124,13 +124,15 @@ newRenderer c dpr lock envRef = Renderer {..} where
     }
 
   -- Scissor operations
-  setScissor rect =
+  setScissor rect = do
+    VG.save c
     VG.scissor c x y w h
     where
       CRect x y w h = rectToCRect rect dpr
 
-  resetScissor =
+  resetScissor = do
     VG.resetScissor c
+    VG.restore c
 
   -- Strokes
   stroke =

src/Monomer/Widget/BaseContainer.hs

@@ -188,11 +188,15 @@ mergeWrapper
   -> WidgetResult s e
 mergeWrapper mergeHandler wenv oldInst newInst = result where
   oldState = widgetGetState (_wiWidget oldInst) wenv
-  WidgetResult uReqs uEvents uInstance = mergeHandler wenv oldState newInst
+  tempInst = newInst {
+    _wiViewport = _wiViewport oldInst,
+    _wiRenderArea = _wiRenderArea oldInst
+  }
+  WidgetResult uReqs uEvents uInstance = mergeHandler wenv oldState tempInst
   oldChildren = _wiChildren oldInst
   updatedChildren = _wiChildren uInstance
   indexes = Seq.fromList [0..length updatedChildren]
-  zipper idx child = cascadeCtx newInst child idx
+  zipper idx child = cascadeCtx tempInst child idx
   newChildren = Seq.zipWith zipper indexes updatedChildren
   (mergedResults, removedResults) = mergeChildren wenv oldChildren newChildren
   mergedChildren = fmap _wrWidget mergedResults

src/Monomer/Widget/BaseSingle.hs

@@ -133,7 +133,7 @@ defaultInit :: SingleInitHandler s e
 defaultInit _ widgetInst = resultWidget widgetInst
 
 defaultMerge :: SingleMergeHandler s e
-defaultMerge wenv oldState newInstance = resultWidget newInstance
+defaultMerge wenv oldState newInst = resultWidget newInst
 
 defaultDispose :: SingleDisposeHandler s e
 defaultDispose _ widgetInst = resultWidget widgetInst
@@ -147,9 +147,13 @@ mergeWrapper
   -> WidgetInstance s e
   -> WidgetInstance s e
   -> WidgetResult s e
-mergeWrapper mergeHandler wenv oldInstance newInstance = result where
-  oldState = widgetGetState (_wiWidget oldInstance) wenv
-  result = mergeHandler wenv oldState newInstance
+mergeWrapper mergeHandler wenv oldInst newInst = result where
+  oldState = widgetGetState (_wiWidget oldInst) wenv
+  tempInst = newInst {
+    _wiViewport = _wiViewport oldInst,
+    _wiRenderArea = _wiRenderArea oldInst
+  }
+  result = mergeHandler wenv oldState tempInst
 
 defaultFindNextFocus :: SingleFindNextFocusHandler s e
 defaultFindNextFocus wenv startFrom widgetInst

src/Monomer/Widget/Util.hs

@@ -218,6 +218,10 @@ getTextGlyphs wenv theme style text = glyphs where
   (font, fontSize) = getFontAndSize theme style
   glyphs = _wpComputeGlyphsPos (_wePlatform wenv) font fontSize text
 
+glyphsLength :: Seq GlyphPos -> Double
+glyphsLength Empty = 0
+glyphsLength (gs :|> g) = _glpXMax g
+
 fitGlyphsCount :: Double -> Double -> Seq GlyphPos -> (Int, Double)
 fitGlyphsCount _ _ Empty = (0, 0)
 fitGlyphsCount totalW currW (g :<| gs)
@@ -305,18 +309,6 @@ activeFgColor wenv inst = fromMaybe themeColor styleColor where
   styleColor = style ^. S.fgColor
   themeColor = theme ^. S.fgColor
 
-textStyle :: StyleState -> TextStyle
-textStyle sst = fromMaybe def (_sstText sst)
-
-textFont :: StyleState -> Font
-textFont style = fromMaybe def (_txsFont $ textStyle style)
-
-textSize :: StyleState -> FontSize
-textSize style = fromMaybe def (_txsFontSize $ textStyle style)
-
-textColor :: StyleState -> Color
-textColor style = fromMaybe def (_txsColor $ textStyle style)
-
 resizeInstance :: WidgetEnv s e -> WidgetInstance s e -> WidgetInstance s e
 resizeInstance wenv inst = newInst where
   viewport = _wiViewport inst

src/Monomer/Widget/Widgets/TextField.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -9,7 +10,7 @@ module Monomer.Widget.Widgets.TextField (
 ) where
 
 import Control.Monad
-import Control.Lens (ALens', (&), (.~))
+import Control.Lens (ALens', (&), (.~), (^.), (^?))
 import Data.Default
 import Data.Maybe
 import Data.Sequence (Seq)
@@ -20,10 +21,12 @@ import qualified Data.Sequence as Seq
 import qualified Data.Text as T
 
 import Monomer.Common.Geometry
+import Monomer.Common.Style
 import Monomer.Common.StyleUtil
 import Monomer.Event.Keyboard
 import Monomer.Event.Types
 import Monomer.Graphics.Drawing
+import Monomer.Graphics.Renderer
 import Monomer.Graphics.Types
 import Monomer.Widget.BaseSingle
 import Monomer.Widget.Types
@@ -37,10 +40,11 @@ data TextFieldCfg s e = TextFieldCfg {
 }
 
 data TextFieldState = TextFieldState {
-  _tfCurrText :: Text,
+  _tfCurrText :: !Text,
   _tfGlyphs :: Seq GlyphPos,
-  _tfCursorPos :: Int,
-  _stSelStart :: Maybe Int
+  _tfCursorPos :: !Int,
+  _tfSelStart :: Maybe Int,
+  _tfOffset :: !Double
 } deriving (Eq, Show, Typeable)
 
 textFieldCfg :: WidgetValue s Text -> TextFieldCfg s e
@@ -56,7 +60,8 @@ textFieldState = TextFieldState {
   _tfCurrText = "",
   _tfGlyphs = Seq.empty,
   _tfCursorPos = 0,
-  _stSelStart = Nothing
+  _tfSelStart = Nothing,
+  _tfOffset = 0
 }
 
 textField :: ALens' s Text -> WidgetInstance s e
@@ -79,21 +84,22 @@ makeTextField config state = widget where
     singleMerge = merge,
     singleHandleEvent = handleEvent,
     singleGetSizeReq = getSizeReq,
+    singleResize = resize,
     singleRender = render
   }
 
-  TextFieldState currText currGlyphs currPos currSel = state
+  TextFieldState currText currGlyphs currPos currSel _ = state
   currentValue wenv = widgetValueGet (_weModel wenv) (_tfcValue config)
 
   init wenv inst = resultWidget newInstance where
     currText = currentValue wenv
-    newState = newTextState wenv inst currText 0 Nothing
+    newState = newTextState wenv inst state currText 0 Nothing
     newInstance = inst {
       _wiWidget = makeTextField config newState
     }
 
   merge wenv oldState inst = resultWidget newInstance where
-    TextFieldState _ _ oldPos oldSel = fromMaybe state (useState oldState)
+    TextFieldState _ _ oldPos oldSel _ = fromMaybe state (useState oldState)
     currText = currentValue wenv
     currTextL = T.length currText
     newPos
@@ -102,7 +108,7 @@ makeTextField config state = widget where
     newSelStart
       | isNothing oldSel || currTextL < fromJust oldSel = Nothing
       | otherwise = oldSel
-    newState = newTextState wenv inst currText newPos newSelStart
+    newState = newTextState wenv inst state currText newPos newSelStart
     newInstance = inst {
       _wiWidget = makeTextField config newState
     }
@@ -175,7 +181,7 @@ makeTextField config state = widget where
         | currText /= newText = widgetValueSet (_tfcValue config) newText
         | otherwise = []
       reqs = reqGetClipboard ++ reqSetClipboard ++ reqUpdateModel
-      newState = newTextState wenv inst newText newPos newSel
+      newState = newTextState wenv inst state newText newPos newSel
       newInstance = inst {
         _wiWidget = makeTextField config newState
       }
@@ -195,7 +201,7 @@ makeTextField config state = widget where
     newPos
       | isJust currSel = 1 + min currPos (fromJust currSel)
       | otherwise = currPos + T.length addedText
-    newState = newTextState wenv inst newText newPos Nothing
+    newState = newTextState wenv inst state newText newPos Nothing
     reqs = widgetValueSet (_tfcValue config) newText
     newInst = inst {
       _wiWidget = makeTextField config newState
@@ -221,15 +227,27 @@ makeTextField config state = widget where
     size = getTextSize wenv theme style currText
     sizeReq = SizeReq size FlexibleSize StrictSize
 
+  resize wenv viewport renderArea inst = newInst where
+    tempInst = inst {
+      _wiViewport = viewport,
+      _wiRenderArea = renderArea
+    }
+    newState = newTextState wenv tempInst state currText currPos currSel
+    newInst = tempInst {
+      _wiWidget = makeTextField config newState
+    }
+
   render renderer wenv inst = do
-    textRect <- drawStyledText renderer contentRect mergedStyle currText
+    setScissor renderer contentRect
+    textRect <- renderContent renderer state contentRect mergedStyle currText
 
     when (isJust currSel) $
-      drawRect renderer (selRect textRect) caretColor Nothing
+      drawRect renderer (selRect textRect) selColor Nothing
 
-    when (isFocused wenv inst && isNothing currSel) $
+    when (isFocused wenv inst) $
       drawRect renderer (caretRect textRect) caretColor Nothing
 
+    resetScissor renderer
     where
       WidgetInstance{..} = inst
       theme = activeTheme wenv inst
@@ -245,30 +263,64 @@ makeTextField config state = widget where
       gw start end = abs $ _glpXMax (glyph end) - _glpXMin (glyph start)
       glyph idx = Seq.index currGlyphs idx
       ts = _weTimestamp wenv
+      selAlpha
+        | isFocused wenv inst = 0.5
+        | otherwise = 0.3
+      selColor = Just $ textColor style & alpha .~ selAlpha
       caretAlpha
-        | isFocused wenv inst = fromIntegral (ts `mod` 1000) / 1000.0
+        | isFocused wenv inst = if (ts `mod` 1000) < 500 then 1 else 0
         | otherwise = 0
       caretColor = Just $ textColor style & alpha .~ caretAlpha
       caretWidth = _tfcCaretWidth config
       caretPos
         | currPos == 0 = 0
         | otherwise = _glpXMax (glyph $ currPos - 1)
-      caretRect (Rect tx ty tw th) = Rect (tx + caretPos) ty caretWidth th
+      caretX tx = max 0 $ min (cx + cw - caretWidth) (tx + caretPos)
+      caretRect (Rect tx ty tw th) = Rect (caretX tx) ty caretWidth th
+
+renderContent
+  :: Renderer -> TextFieldState -> Rect -> StyleState -> Text -> IO Rect
+renderContent renderer state viewport style currText =
+  drawText renderer tsRect tsColor tsFont tsFontSize tsAlign currText
+  where
+    Rect x y w h = viewport
+    textW = glyphsLength $ _tfGlyphs state
+    !tsRect = Rect (x + _tfOffset state) y textW h
+    tsFont = textFont style
+    tsFontSize = textSize style
+    tsColor = textColor style
+    tsAlignV = textAlignV style
+    tsAlign = Align ALeft tsAlignV
 
 newTextState
   :: WidgetEnv s e
   -> WidgetInstance s e
+  -> TextFieldState
   -> Text
   -> Int
   -> Maybe Int
   -> TextFieldState
-newTextState wenv inst text cursor selection = newState where
+newTextState wenv inst oldState text cursor selection = newState where
   theme = activeTheme wenv inst
   style = activeStyle wenv inst
+  Rect cx cy cw ch = getContentRect style inst
   glyphs = getTextGlyphs wenv theme style text
+  curX = maybe 0 _glpXMax $ Seq.lookup (cursor - 1) glyphs
+  oldOffset = _tfOffset oldState
+  textW = glyphsLength glyphs
+  textFits = cw >= textW
+  align = fromMaybe ALeft (_txsAlignH $ textStyle style)
+  newOffset
+    | textFits && align == ALeft = 0
+    | textFits && align == ACenter = (cw - textW) / 2
+    | textFits && align == ARight = cw - textW
+    | curX + oldOffset > cw = cw - curX
+    | curX + oldOffset < 0 = -curX
+    | otherwise = oldOffset
   newState = TextFieldState {
     _tfCurrText = text,
     _tfGlyphs = glyphs,
     _tfCursorPos = cursor,
-    _stSelStart = selection
+    _tfSelStart = selection,
+    _tfOffset = newOffset
   }