never executed always true always false
    1 {-|
    2 Module: Flaw.UI.EditBox
    3 Description: One-line edit box.
    4 License: MIT
    5 -}
    6 
    7 module Flaw.UI.EditBox
    8   ( EditBox(..)
    9   , newEditBox
   10   ) where
   11 
   12 import Control.Concurrent.STM
   13 import Control.Monad
   14 import Control.Monad.IO.Class
   15 import Data.List
   16 import Data.Maybe
   17 import qualified Data.Text as T
   18 
   19 import Flaw.Graphics
   20 import Flaw.Graphics.Canvas
   21 import Flaw.Graphics.Font
   22 import Flaw.Graphics.Font.Render
   23 import Flaw.Input.Keyboard
   24 import Flaw.Input.Mouse
   25 import Flaw.Math
   26 import Flaw.UI
   27 import Flaw.UI.Drawer
   28 import Flaw.UI.Metrics
   29 
   30 -- | Edit box.
   31 data EditBox = EditBox
   32   { editBoxTextVar :: !(TVar T.Text)
   33   , editBoxTextScriptVar :: !(TVar FontScript)
   34   , editBoxPasswordModeVar :: !(TVar Bool)
   35   -- | Start and end position of selection.
   36   , editBoxSelectionVar :: !(TVar (Int, Int))
   37   -- | Scroll offset in pixels. Positive means rendered text shifted to the left.
   38   , editBoxScrollVar :: !(TVar Float)
   39   , editBoxSizeVar :: !(TVar Size)
   40   , editBoxLastMousePositionVar :: !(TVar (Maybe Position))
   41   , editBoxMousePressedVar :: !(TVar Bool)
   42   , editBoxFocusedVar :: !(TVar Bool)
   43   , editBoxBlinkVar :: !(TVar Float)
   44   , editBoxDelayedOpVar :: !(TVar DelayedOp)
   45   }
   46 
   47 -- | Operation delayed to rendering time.
   48 data DelayedOp
   49   = EmptyDelayedOp
   50   | SetSelectionEndDelayedOp
   51   | SetSelectionDelayedOp
   52   deriving (Eq, Ord)
   53 
   54 newEditBox :: STM EditBox
   55 newEditBox = do
   56   textVar <- newTVar T.empty
   57   textScriptVar <- newTVar fontScriptUnknown
   58   passwordModeVar <- newTVar False
   59   selectionVar <- newTVar (0, 0)
   60   scrollVar <- newTVar 0
   61   sizeVar <- newTVar $ Vec2 0 0
   62   lastMousePositionVar <- newTVar Nothing
   63   mousePressedVar <- newTVar False
   64   focusedVar <- newTVar False
   65   blinkVar <- newTVar 0
   66   delayedOpVar <- newTVar EmptyDelayedOp
   67   return EditBox
   68     { editBoxTextVar = textVar
   69     , editBoxTextScriptVar = textScriptVar
   70     , editBoxPasswordModeVar = passwordModeVar
   71     , editBoxSelectionVar = selectionVar
   72     , editBoxScrollVar = scrollVar
   73     , editBoxSizeVar = sizeVar
   74     , editBoxLastMousePositionVar = lastMousePositionVar
   75     , editBoxMousePressedVar = mousePressedVar
   76     , editBoxFocusedVar = focusedVar
   77     , editBoxBlinkVar = blinkVar
   78     , editBoxDelayedOpVar = delayedOpVar
   79     }
   80 
   81 instance Element EditBox where
   82 
   83   layoutElement EditBox
   84     { editBoxSizeVar = sizeVar
   85     } = writeTVar sizeVar
   86 
   87   dabElement EditBox
   88     { editBoxSizeVar = sizeVar
   89     } (Vec2 x y) =
   90     if x < 0 || y < 0 then return False
   91     else do
   92       size <- readTVar sizeVar
   93       let
   94         Vec2 sx sy = size
   95         in return $ x < sx && y < sy
   96 
   97   elementMouseCursor _ = return MouseCursorIBeam
   98 
   99   renderElement EditBox
  100     { editBoxTextVar = textVar
  101     , editBoxTextScriptVar = textScriptVar
  102     , editBoxPasswordModeVar = passwordModeVar
  103     , editBoxSelectionVar = selectionVar
  104     , editBoxScrollVar = scrollVar
  105     , editBoxSizeVar = sizeVar
  106     , editBoxLastMousePositionVar = lastMousePositionVar
  107     , editBoxFocusedVar = focusedVar
  108     , editBoxBlinkVar = blinkVar
  109     , editBoxDelayedOpVar = delayedOpVar
  110     } Drawer
  111     { drawerCanvas = canvas
  112     , drawerGlyphRenderer = glyphRenderer
  113     , drawerFrameTimeVar = frameTimeVar
  114     , drawerStyles = DrawerStyles
  115       { drawerEditFont = DrawerFont
  116         { drawerFontRenderableFontCache = renderableFontCache@RenderableFontCache
  117           { renderableFontCacheMaybeFontVar = maybeFontVar
  118           }
  119         , drawerFontShaper = SomeFontShaper fontShaper
  120         }
  121       , drawerLoweredStyleVariant = StyleVariant
  122         { styleVariantNormalStyle = normalStyle
  123         , styleVariantMousedStyle = mousedStyle
  124         , styleVariantSelectedFocusedStyle = selectedFocusedStyle
  125         , styleVariantSelectedUnfocusedStyle = selectedUnfocusedStyle
  126         }
  127       }
  128     } (Vec2 px py) = do
  129     passwordMode <- readTVar passwordModeVar
  130     text <- (\text -> if passwordMode then T.map (const '‚óŹ') text else text) <$> readTVar textVar
  131     textScript <- readTVar textScriptVar
  132     size <- readTVar sizeVar
  133     maybeLastMousePosition <- readTVar lastMousePositionVar
  134     focused <- readTVar focusedVar
  135     let
  136       Vec2 sx sy = size
  137       moused = isJust maybeLastMousePosition
  138       style = if moused || focused then mousedStyle else normalStyle
  139 
  140     -- split text according to selection
  141     (selectionStart, selectionEnd) <- readTVar selectionVar
  142     let
  143       selectionMin = min selectionStart selectionEnd
  144       selectionMax = max selectionStart selectionEnd
  145       (textBefore, textSelected, textAfter) = splitTextBySelection text selectionMin selectionMax
  146 
  147       selectedStyle = if focused then selectedFocusedStyle else selectedUnfocusedStyle
  148 
  149     -- update blinking phase (only do calculations if we are focused)
  150     blink <-
  151       if focused then do
  152         frameTime <- readTVar frameTimeVar
  153         let
  154           blinkPeriod = 1
  155         oldBlink <- readTVar blinkVar
  156         let
  157           blink = snd (properFraction $ oldBlink + frameTime / blinkPeriod :: (Int, Float))
  158         writeTVar blinkVar blink
  159         return blink
  160       else return 0
  161 
  162     return $ do
  163 
  164       -- draw edit box
  165       drawBorderedRectangle canvas
  166         (Vec4 px (px + 1) (px + sx - 1) (px + sx))
  167         (Vec4 py (py + 1) (py + sy - 1) (py + sy))
  168         (styleFillColor style) (styleBorderColor style)
  169 
  170       -- constrain further rendering
  171       renderIntersectScissor $ Vec4 (px + 1) (py + 1) (px + sx - 1) (py + sy - 1)
  172 
  173       -- manually shape glyphs
  174       runs@[beforeRun, selectedRun, _afterRun] <- liftIO $ shapeText fontShaper [textBefore, textSelected, textAfter] textScript
  175 
  176       let
  177         -- special offset for cursor and selection relative to text
  178         hackyOffsetX = 1
  179         selectionMinX = hackyOffsetX + x_ (snd beforeRun)
  180         selectionMaxX = hackyOffsetX + x_ (snd selectedRun)
  181         cursorX = if selectionStart < selectionEnd then selectionMaxX else selectionMinX
  182 
  183         -- offset from left side
  184         textOffsetX = 1
  185 
  186       -- try to get font metrics
  187       maybeFont <- liftIO $ atomically $ readTMVar maybeFontVar
  188       let
  189         Vec4 _boxLeft boxTop _boxRight boxBottom = case maybeFont of
  190           Just RenderableFont
  191             { renderableFontMaxGlyphBox = maxGlyphBox
  192             } -> maxGlyphBox
  193           Nothing -> Vec4 0 0 0 0
  194 
  195       -- calculate scroll
  196       scroll <- liftIO $ atomically $ do
  197         scroll <- readTVar scrollVar
  198         let
  199           border = 3
  200           -- so this should be true: border < textPreX + cursorX < sx - 2 - border
  201           -- which means: border < textOffsetX - scroll + cursorX < sx - 2 - border
  202           -- border - textOffsetX - cursorX < -scroll < sx - textOffsetX - cursorX - border - 2
  203           -- cursorX + textOffsetX - sx + border + 2 < scroll < cursorX + textOffsetX - border
  204           minScroll = cursorX + textOffsetX - fromIntegral sx + border + 2
  205           maxScroll = cursorX + textOffsetX - border
  206         if scroll <= minScroll then do
  207           writeTVar scrollVar minScroll
  208           return minScroll
  209         else if scroll >= maxScroll then do
  210           let
  211             newScroll = max 0 $ maxScroll - fromIntegral sx / 3
  212           writeTVar scrollVar newScroll
  213           return newScroll
  214         else return scroll
  215 
  216       let
  217         textXY@(Vec2 textX _textY) = Vec2 (fromIntegral px + 1 + textOffsetX - scroll) (fromIntegral py + 1 + (fromIntegral (sy - 2) - boxTop - boxBottom) * 0.5)
  218         selectionTop = py + 2
  219         selectionBottom = py + sy - 2
  220 
  221         -- function calculating best text split for a given cursor position
  222         splitTextByX x = do
  223           let
  224             calc m = do
  225               let (a, b) = T.splitAt m text
  226               [(_, Vec2 cx _cy), _] <- shapeText fontShaper [a, b] textScript
  227               return cx
  228             step l r = if l + 1 >= r then return (l, r) else do
  229               let m = (l + r) `quot` 2
  230               cx <- calc m
  231               if x >= cx then step m r else step l m
  232             len = T.length text
  233           (l, r) <- step 0 len
  234           (minimumBy (\a b -> compare (abs $ x - fst a) (abs $ x - fst b)) <$>) . forM (filter (\i -> i >= 0 && i <= len) [(l - 1)..(r + 1)]) $ \i -> do
  235             cx <- calc i
  236             return (cx, i)
  237 
  238       -- get position of floating cursor
  239       maybeFloatingCursor <- case maybeLastMousePosition of
  240         Just (Vec2 qx _qy) -> (Just <$>) . liftIO $ splitTextByX $ fromIntegral (px + qx) - textX
  241         Nothing -> return Nothing
  242 
  243       -- process delayed op
  244       liftIO $ atomically $ do
  245         delayedOp <- readTVar delayedOpVar
  246         case delayedOp of
  247           EmptyDelayedOp -> return ()
  248           SetSelectionEndDelayedOp -> do
  249             case maybeFloatingCursor of
  250               Just (_, floatingCursor) -> do
  251                 writeTVar selectionVar (selectionStart, floatingCursor)
  252                 writeTVar blinkVar 0 -- reset blink
  253               Nothing -> return ()
  254             writeTVar delayedOpVar EmptyDelayedOp
  255           SetSelectionDelayedOp -> do
  256             case maybeFloatingCursor of
  257               Just (_, floatingCursor) -> do
  258                 writeTVar selectionVar (floatingCursor, floatingCursor)
  259                 writeTVar blinkVar 0 -- reset blink
  260               Nothing -> return ()
  261             writeTVar delayedOpVar EmptyDelayedOp
  262 
  263       -- draw selection
  264       unless (T.null textSelected) $ drawBorderedRectangle canvas
  265         (Vec4 (floor $ textX + selectionMinX - 1) (floor $ textX + selectionMinX) (floor $ textX + selectionMaxX + 1) (floor $ textX + selectionMaxX + 2))
  266         (Vec4 selectionTop (selectionTop + 1) (selectionBottom - 1) selectionBottom)
  267         (styleFillColor selectedStyle) (styleBorderColor selectedStyle)
  268 
  269       -- draw blinking cursor
  270       when (blink * 2 < 1) $ drawBorderedRectangle canvas
  271         (Vec4 (floor $ textX + cursorX) (floor $ textX + cursorX + 1) (floor $ textX + cursorX + 1) (floor $ textX + cursorX + 1))
  272         (Vec4 selectionTop (selectionTop + 1) (selectionBottom - 1) selectionBottom)
  273         (styleFillColor selectedStyle) (styleBorderColor selectedStyle)
  274 
  275       -- draw floating cursor
  276       case maybeFloatingCursor of
  277         Just (floatingCursorX, _) -> drawBorderedRectangle canvas
  278           (Vec4 (floor $ textX + floatingCursorX) (floor $ textX + floatingCursorX + 1) (floor $ textX + floatingCursorX + 1) (floor $ textX + floatingCursorX + 1))
  279           (Vec4 selectionTop (selectionTop + 1) (selectionBottom - 1) selectionBottom)
  280           (styleFillColor selectedStyle) (styleFillColor selectedStyle)
  281         Nothing -> return ()
  282 
  283       -- render glyphs
  284       renderGlyphs glyphRenderer renderableFontCache $
  285         forM_ (zip runs [styleTextColor style, styleTextColor selectedStyle, styleTextColor style]) $ \((shapedGlyphs, _advance), color) ->
  286           renderTextRun shapedGlyphs textXY color
  287 
  288   processInputEvent EditBox
  289     { editBoxTextVar = textVar
  290     , editBoxSelectionVar = selectionVar
  291     , editBoxLastMousePositionVar = lastMousePositionVar
  292     , editBoxMousePressedVar = mousePressedVar
  293     , editBoxBlinkVar = blinkVar
  294     , editBoxDelayedOpVar = delayedOpVar
  295     } inputEvent InputState
  296     { inputStateKeyboard = keyboardState
  297     , inputStateGetClipboardText = getClipboardText
  298     , inputStateSetClipboardText = setClipboardText
  299     } = case inputEvent of
  300     KeyboardInputEvent keyboardEvent -> case keyboardEvent of
  301       KeyDownEvent key -> case key of
  302         KeyBackSpace -> do
  303           text <- readTVar textVar
  304           (selectionStart, selectionEnd) <- readTVar selectionVar
  305           if selectionStart == selectionEnd then do
  306             let
  307               (textBefore, textAfter) = T.splitAt selectionEnd text
  308             when (T.length textBefore > 0) $ do
  309               writeTVar textVar $ mappend (T.init textBefore) textAfter
  310               writeTVar selectionVar (selectionEnd - 1, selectionEnd - 1)
  311               dontBlink
  312           else replaceSelection T.empty
  313           return True
  314         KeyDelete -> do
  315           text <- readTVar textVar
  316           (selectionStart, selectionEnd) <- readTVar selectionVar
  317           if selectionStart == selectionEnd then do
  318             let
  319               (textBefore, textAfter) = T.splitAt selectionEnd text
  320             when (T.length textAfter > 0) $ do
  321               writeTVar textVar $ mappend textBefore (T.tail textAfter)
  322               dontBlink
  323           else do
  324             shiftPressed <- isShiftPressed
  325             -- Shift+Del - cut to clipboard
  326             when shiftPressed $ setClipboardText =<< getSelectedText
  327             replaceSelection T.empty
  328           return True
  329         KeyLeft -> do
  330           (_selectionStart, selectionEnd) <- readTVar selectionVar
  331           moveCursor $ selectionEnd - 1
  332           return True
  333         KeyRight -> do
  334           (_selectionStart, selectionEnd) <- readTVar selectionVar
  335           moveCursor $ selectionEnd + 1
  336           return True
  337         KeyHome -> do
  338           moveCursor 0
  339           return True
  340         KeyEnd -> do
  341           text <- readTVar textVar
  342           moveCursor $ T.length text
  343           return True
  344         KeyInsert -> do
  345           controlPressed <- isControlPressed
  346           shiftPressed <- isShiftPressed
  347           if controlPressed then
  348             if shiftPressed then return False
  349             else do
  350               -- Ctrl+Ins - copy to clipboard
  351               setClipboardText =<< getSelectedText
  352               return True
  353           else
  354             if shiftPressed then do
  355               -- Shift+Ins - paste from clipboard
  356               getClipboardText replaceSelection
  357               return True
  358             else return False
  359         KeyA -> do
  360           controlPressed <- isControlPressed
  361           if controlPressed then do
  362             -- select all
  363             text <- readTVar textVar
  364             writeTVar selectionVar (0, T.length text)
  365             dontBlink
  366             return True
  367           else return False
  368         KeyC -> do
  369           controlPressed <- isControlPressed
  370           if controlPressed then do
  371             -- Ctrl+C - copy to clipboard
  372             setClipboardText =<< getSelectedText
  373             return True
  374           else return False
  375         KeyV -> do
  376           controlPressed <- isControlPressed
  377           if controlPressed then do
  378             -- Ctrl+V - paste from clipboard
  379             getClipboardText replaceSelection
  380             return True
  381           else return False
  382         KeyX -> do
  383           controlPressed <- isControlPressed
  384           if controlPressed then do
  385             -- Ctrl+X - cut to clipboard
  386             setClipboardText =<< getSelectedText
  387             replaceSelection T.empty
  388             return True
  389           else return False
  390         _ -> return False
  391       CharEvent char ->
  392         -- ignore control characters
  393         if char > '\x1f' then do
  394           replaceSelection $ T.singleton char
  395           return True
  396         else return False
  397       _ -> return False
  398     MouseInputEvent mouseEvent -> case mouseEvent of
  399       MouseDownEvent LeftMouseButton -> do
  400         maybeLastMousePosition <- readTVar lastMousePositionVar
  401         if isJust maybeLastMousePosition then do
  402           setDelayedOp SetSelectionDelayedOp
  403           writeTVar mousePressedVar True
  404           return True
  405         else return False
  406       MouseUpEvent LeftMouseButton -> do
  407         writeTVar mousePressedVar False
  408         return True
  409       CursorMoveEvent x y -> do
  410         let
  411           mousePosition = Vec2 x y
  412         writeTVar lastMousePositionVar $ Just mousePosition
  413         mousePressed <- readTVar mousePressedVar
  414         when mousePressed $ setDelayedOp SetSelectionEndDelayedOp
  415         return True
  416       _ -> return False
  417     MouseLeaveEvent -> do
  418       writeTVar lastMousePositionVar Nothing
  419       writeTVar mousePressedVar False
  420       return True
  421     where
  422       replaceSelection replacementText = do
  423         text <- readTVar textVar
  424         (selectionStart, selectionEnd) <- readTVar selectionVar
  425         let
  426           (textBefore, _textSelected, textAfter) = splitTextBySelection text selectionStart selectionEnd
  427         writeTVar textVar $ mconcat [textBefore, replacementText, textAfter]
  428         let
  429           newSelection = min selectionStart selectionEnd + T.length replacementText
  430         writeTVar selectionVar (newSelection, newSelection)
  431         dontBlink
  432       moveCursor position = do
  433         (selectionStart, _selectionEnd) <- readTVar selectionVar
  434         text <- readTVar textVar
  435         let
  436           newSelectionEnd = max 0 $ min (T.length text) position
  437         shiftPressed <- isShiftPressed
  438         let
  439           newSelectionStart = if shiftPressed then selectionStart else newSelectionEnd
  440         writeTVar selectionVar (newSelectionStart, newSelectionEnd)
  441         dontBlink
  442       dontBlink = writeTVar blinkVar 0
  443       isControlPressed = do
  444         controlLPressed <- getKeyState keyboardState KeyControlL
  445         controlRPressed <- getKeyState keyboardState KeyControlR
  446         return $ controlLPressed || controlRPressed
  447       isShiftPressed = do
  448         shiftLPressed <- getKeyState keyboardState KeyShiftL
  449         shiftRPressed <- getKeyState keyboardState KeyShiftR
  450         return $ shiftLPressed || shiftRPressed
  451       getSelectedText = do
  452         text <- readTVar textVar
  453         (selectionStart, selectionEnd) <- readTVar selectionVar
  454         let
  455           (_textBefore, textSelected, _textAfter) = splitTextBySelection text selectionStart selectionEnd
  456         return textSelected
  457       setDelayedOp newOp = do
  458         oldOp <- readTVar delayedOpVar
  459         when (newOp > oldOp) $ writeTVar delayedOpVar newOp
  460 
  461   focusElement EditBox
  462     { editBoxFocusedVar = focusedVar
  463     , editBoxBlinkVar = blinkVar
  464     } = do
  465     writeTVar focusedVar True
  466     -- reset blinking (it's just more pleasant to see cursor immediately)
  467     writeTVar blinkVar 0
  468     return True
  469 
  470   unfocusElement EditBox
  471     { editBoxFocusedVar = focusedVar
  472     } = writeTVar focusedVar False
  473 
  474 instance HasText EditBox where
  475   setText EditBox
  476     { editBoxTextVar = textVar
  477     , editBoxSelectionVar = selectionVar
  478     } text = do
  479     writeTVar textVar text
  480     writeTVar selectionVar (0, 0)
  481   setTextScript EditBox
  482     { editBoxTextScriptVar = textScriptVar
  483     } = writeTVar textScriptVar
  484   getText EditBox
  485     { editBoxTextVar = textVar
  486     } = readTVar textVar
  487 
  488 instance HasPassword EditBox where
  489   setPasswordMode EditBox
  490     { editBoxPasswordModeVar = passwordModeVar
  491     } = writeTVar passwordModeVar
  492 
  493 instance HasPreferredSize EditBox where
  494   preferredSize Metrics
  495     { metricsMainWidth = width
  496     , metricsEditBoxHeight = height
  497     } _ = Vec2 width height
  498 
  499 splitTextBySelection :: T.Text -> Int -> Int -> (T.Text, T.Text, T.Text)
  500 splitTextBySelection text start end = (before, selected, after) where
  501   (before, selectedAndAfter) = T.splitAt (min start end) text
  502   (selected, after) = T.splitAt (abs $ start - end) selectedAndAfter