never executed always true always false
    1 {-|
    2 Module: Flaw.UI.ScrollBox
    3 Description: Scroll box.
    4 License: MIT
    5 -}
    6 
    7 module Flaw.UI.ScrollBox
    8   ( ScrollBox(..)
    9   , newScrollBox
   10   , ScrollBar(..)
   11   , newScrollBar
   12   , newVerticalScrollBar
   13   , newHorizontalScrollBar
   14   , processScrollBarEvent
   15   , ensureVisibleScrollBoxArea
   16   ) where
   17 
   18 import Control.Concurrent.STM
   19 import Control.Monad
   20 import Data.Maybe
   21 
   22 import Flaw.Graphics
   23 import Flaw.Graphics.Canvas
   24 import Flaw.Input.Mouse
   25 import Flaw.Math
   26 import Flaw.UI
   27 import Flaw.UI.Drawer
   28 
   29 data ScrollBox = ScrollBox
   30   { scrollBoxElement :: !SomeScrollable
   31   -- | Position of left-top corner of child element
   32   -- relative to scroll box' left-top corner, i.e. <= 0.
   33   , scrollBoxScrollVar :: {-# UNPACK #-} !(TVar Position)
   34   , scrollBoxSizeVar :: {-# UNPACK #-} !(TVar Size)
   35   }
   36 
   37 newScrollBox :: Scrollable e => e -> STM ScrollBox
   38 newScrollBox element = do
   39   scrollVar <- newTVar $ Vec2 0 0
   40   sizeVar <- newTVar $ Vec2 0 0
   41   return ScrollBox
   42     { scrollBoxElement = SomeScrollable element
   43     , scrollBoxScrollVar = scrollVar
   44     , scrollBoxSizeVar = sizeVar
   45     }
   46 
   47 instance Element ScrollBox where
   48 
   49   layoutElement ScrollBox
   50     { scrollBoxElement = SomeScrollable element
   51     , scrollBoxSizeVar = sizeVar
   52     } size = do
   53     writeTVar sizeVar size
   54     layoutElement element size
   55 
   56   dabElement ScrollBox
   57     { scrollBoxElement = SomeScrollable element
   58     , scrollBoxScrollVar = scrollVar
   59     , scrollBoxSizeVar = sizeVar
   60     } (Vec2 x y) = if x < 0 || y < 0 then return False else do
   61     size <- readTVar sizeVar
   62     let Vec2 sx sy = size
   63     if x < sx && y < sy then do
   64       scroll <- readTVar scrollVar
   65       let Vec2 ox oy = scroll
   66       dabElement element $ Vec2 (x - ox) (y - oy)
   67     else return False
   68 
   69   elementMouseCursor ScrollBox
   70     { scrollBoxElement = SomeScrollable element
   71     } = elementMouseCursor element
   72 
   73   renderElement ScrollBox
   74     { scrollBoxElement = SomeScrollable element
   75     , scrollBoxScrollVar = scrollVar
   76     , scrollBoxSizeVar = sizeVar
   77     } drawer position@(Vec2 px py) = do
   78     scroll <- readTVar scrollVar
   79     size <- readTVar sizeVar
   80     ssize <- scrollableElementSize element
   81     -- correct scroll if needed
   82     let
   83       Vec2 ox oy = scroll
   84       Vec2 sx sy = size
   85       Vec2 ssx ssy = ssize
   86       newScroll@(Vec2 nox noy) = Vec2
   87         (min 0 $ max ox $ sx - ssx)
   88         (min 0 $ max oy $ sy - ssy)
   89 
   90     when (scroll /= newScroll) $ writeTVar scrollVar newScroll
   91     r <- renderScrollableElement element drawer (position + newScroll) (Vec4 (-nox) (-noy) (sx - nox) (sy - noy))
   92     return $ do
   93       renderIntersectScissor $ Vec4 px py (px + sx) (py + sy)
   94       r
   95 
   96   processInputEvent ScrollBox
   97     { scrollBoxElement = SomeScrollable element
   98     , scrollBoxScrollVar = scrollVar
   99     } inputEvent inputState = case inputEvent of
  100     MouseInputEvent mouseEvent -> case mouseEvent of
  101       CursorMoveEvent x y -> do
  102         scroll <- readTVar scrollVar
  103         let Vec2 ox oy = scroll
  104         processInputEvent element (MouseInputEvent (CursorMoveEvent (x - ox) (y - oy))) inputState
  105       _ -> processInputEvent element inputEvent inputState
  106     _ -> processInputEvent element inputEvent inputState
  107 
  108   focusElement ScrollBox
  109     { scrollBoxElement = SomeScrollable element
  110     } = focusElement element
  111 
  112   unfocusElement ScrollBox
  113     { scrollBoxElement = SomeScrollable element
  114     } = unfocusElement element
  115 
  116 data ScrollBar = ScrollBar
  117   { scrollBarScrollBox :: !ScrollBox
  118   , scrollBarDirection :: {-# UNPACK #-} !(Vec2 Metric)
  119   , scrollBarSizeVar :: {-# UNPACK #-} !(TVar Size)
  120   , scrollBarLastMousePositionVar :: {-# UNPACK #-} !(TVar (Maybe Position))
  121   , scrollBarPressedVar :: {-# UNPACK #-} !(TVar Bool)
  122   }
  123 
  124 newScrollBar :: Vec2 Metric -> ScrollBox -> STM ScrollBar
  125 newScrollBar direction scrollBox = do
  126   sizeVar <- newTVar $ Vec2 0 0
  127   lastMousePositionVar <- newTVar Nothing
  128   pressedVar <- newTVar False
  129   return ScrollBar
  130     { scrollBarScrollBox = scrollBox
  131     , scrollBarDirection = direction
  132     , scrollBarSizeVar = sizeVar
  133     , scrollBarLastMousePositionVar = lastMousePositionVar
  134     , scrollBarPressedVar = pressedVar
  135     }
  136 
  137 newVerticalScrollBar :: ScrollBox -> STM ScrollBar
  138 newVerticalScrollBar = newScrollBar $ Vec2 0 1
  139 
  140 newHorizontalScrollBar :: ScrollBox -> STM ScrollBar
  141 newHorizontalScrollBar = newScrollBar $ Vec2 1 0
  142 
  143 instance Element ScrollBar where
  144 
  145   layoutElement ScrollBar
  146     { scrollBarSizeVar = sizeVar
  147     } = writeTVar sizeVar
  148 
  149   dabElement ScrollBar
  150     { scrollBarSizeVar = sizeVar
  151     } (Vec2 x y) = if x < 0 || y < 0 then return False else do
  152     size <- readTVar sizeVar
  153     let Vec2 sx sy = size
  154     return $ x < sx && y < sy
  155 
  156   renderElement scrollBar@ScrollBar
  157     { scrollBarSizeVar = barSizeVar
  158     , scrollBarLastMousePositionVar = lastMousePositionVar
  159     , scrollBarPressedVar = pressedVar
  160     } Drawer
  161     { drawerCanvas = canvas
  162     , drawerStyles = DrawerStyles
  163       { drawerFlatStyleVariant = StyleVariant
  164         { styleVariantNormalStyle = flatNormalStyle
  165         }
  166       , drawerRaisedStyleVariant = StyleVariant
  167         { styleVariantNormalStyle = raisedNormalStyle
  168         , styleVariantMousedStyle = raisedMousedStyle
  169         , styleVariantPressedStyle = raisedPressedStyle
  170         }
  171       }
  172     } (Vec2 px py) = do
  173     barSize <- readTVar barSizeVar
  174     let Vec2 sx sy = barSize
  175     piece <- scrollBarPiece scrollBar
  176     moused <- isJust <$> readTVar lastMousePositionVar
  177     pressed <- readTVar pressedVar
  178     let
  179       pieceStyle
  180         | pressed = raisedPressedStyle
  181         | moused = raisedMousedStyle
  182         | otherwise = raisedNormalStyle
  183     return $ do
  184       -- render border
  185       drawBorderedRectangle canvas
  186         (Vec4 px (px + 1) (px + sx - 1) (px + sx))
  187         (Vec4 py (py + 1) (py + sy - 1) (py + sy))
  188         (styleFillColor flatNormalStyle) (styleBorderColor flatNormalStyle)
  189       case piece of
  190         Just ScrollBarPiece
  191           { scrollBarPieceRect = pieceRect
  192           } -> let Vec4 ppx ppy pqx pqy = pieceRect + Vec4 px py px py in
  193           -- render piece
  194           drawBorderedRectangle canvas
  195             (Vec4 ppx (ppx + 1) (pqx - 1) pqx)
  196             (Vec4 ppy (ppy + 1) (pqy - 1) pqy)
  197             (styleFillColor pieceStyle) (styleBorderColor pieceStyle)
  198         Nothing -> return ()
  199 
  200   processInputEvent scrollBar@ScrollBar
  201     { scrollBarScrollBox = ScrollBox
  202       { scrollBoxScrollVar = scrollVar
  203       }
  204     , scrollBarLastMousePositionVar = lastMousePositionVar
  205     , scrollBarPressedVar = pressedVar
  206     } inputEvent _inputState = case inputEvent of
  207     MouseInputEvent mouseEvent -> case mouseEvent of
  208       MouseDownEvent LeftMouseButton -> do
  209         writeTVar pressedVar True
  210         return True
  211       MouseUpEvent LeftMouseButton -> do
  212         writeTVar pressedVar False
  213         return True
  214       RawMouseMoveEvent _x _y z -> do
  215         piece <- scrollBarPiece scrollBar
  216         case piece of
  217           Just ScrollBarPiece
  218             { scrollBarPieceOffsetMultiplier = offsetMultiplier
  219             } -> do
  220             modifyTVar' scrollVar (+ signum offsetMultiplier * vecFromScalar (floor (z * (-15))))
  221             return True
  222           Nothing -> return False
  223       CursorMoveEvent x y -> do
  224         pressed <- readTVar pressedVar
  225         when pressed $ do
  226           maybeLastMousePosition <- readTVar lastMousePositionVar
  227           case maybeLastMousePosition of
  228             Just lastMousePosition -> do
  229               piece <- scrollBarPiece scrollBar
  230               case piece of
  231                 Just ScrollBarPiece
  232                   { scrollBarPieceOffsetMultiplier = offsetMultiplier
  233                   } -> modifyTVar' scrollVar (+ (Vec2 x y - lastMousePosition) * offsetMultiplier)
  234                 Nothing -> return ()
  235             Nothing -> return ()
  236         writeTVar lastMousePositionVar $ Just $ Vec2 x y
  237         return True
  238       _ -> return False
  239     MouseLeaveEvent -> do
  240       writeTVar lastMousePositionVar Nothing
  241       writeTVar pressedVar False
  242       return True
  243     _ -> return False
  244 
  245 -- | Internal information about piece.
  246 data ScrollBarPiece = ScrollBarPiece
  247   { scrollBarPieceRect :: {-# UNPACK #-} !Rect
  248   , scrollBarPieceOffsetMultiplier :: {-# UNPACK #-} !(Vec2 Metric)
  249   }
  250 
  251 -- | Get scroll bar piece rect and piece offset multiplier.
  252 scrollBarPiece :: ScrollBar -> STM (Maybe ScrollBarPiece)
  253 scrollBarPiece ScrollBar
  254   { scrollBarScrollBox = ScrollBox
  255     { scrollBoxElement = SomeScrollable element
  256     , scrollBoxScrollVar = scrollVar
  257     , scrollBoxSizeVar = boxSizeVar
  258     }
  259   , scrollBarDirection = direction
  260   , scrollBarSizeVar = barSizeVar
  261   } = do
  262   barSize <- readTVar barSizeVar
  263   let Vec2 sx sy = barSize
  264   boxSize <- readTVar boxSizeVar
  265   scrollableSize <- scrollableElementSize element
  266   scroll <- readTVar scrollVar
  267   let
  268     padding = 2
  269     contentOffset = dot scroll direction
  270     boxLength = dot boxSize direction
  271     contentLength = dot scrollableSize direction
  272     barLength = dot barSize direction - padding * 2
  273     minPieceLength = min sx sy - padding * 2
  274     pieceLength = max minPieceLength $ (barLength * boxLength) `quot` max 1 contentLength
  275     pieceOffset = (negate contentOffset * (barLength - pieceLength)) `quot` max 1 (contentLength - boxLength)
  276     Vec2 ppx ppy = vecFromScalar padding + direction * vecFromScalar pieceOffset
  277     Vec2 psx psy = vecfmap (max minPieceLength) $ direction * vecFromScalar pieceLength
  278     piece = if contentLength > boxLength then
  279       Just ScrollBarPiece
  280         { scrollBarPieceRect = Vec4 ppx ppy (ppx + psx) (ppy + psy)
  281         , scrollBarPieceOffsetMultiplier = direction * vecFromScalar (negate $ (contentLength - boxLength) `quot` max 1 (barLength - pieceLength))
  282         }
  283       else Nothing
  284   return piece
  285 
  286 -- | Process possibly scroll bar event.
  287 -- Could be used for passing scrolling events from other elements.
  288 processScrollBarEvent :: ScrollBar -> InputEvent -> InputState -> STM Bool
  289 processScrollBarEvent scrollBar inputEvent inputState = case inputEvent of
  290   MouseInputEvent RawMouseMoveEvent {} -> processInputEvent scrollBar inputEvent inputState
  291   _ -> return False
  292 
  293 -- | Adjust scrolling so the specified area (in content coords) is visible.
  294 ensureVisibleScrollBoxArea :: ScrollBox -> Rect -> STM ()
  295 ensureVisibleScrollBoxArea ScrollBox
  296   { scrollBoxScrollVar = scrollVar
  297   , scrollBoxSizeVar = sizeVar
  298   } (Vec4 left top right bottom) = do
  299   scroll <- readTVar scrollVar
  300   let Vec2 ox oy = scroll
  301   size <- readTVar sizeVar
  302   let Vec2 sx sy = size
  303   -- dimensions are to be adjusted independently
  304   -- function to adjust one dimension
  305   let
  306     adjust o s a b =
  307       if a + o >= 0 then
  308         if b + o <= s then o
  309         else s - b
  310       else -a
  311     newScroll = Vec2 (adjust ox sx left right) (adjust oy sy top bottom)
  312   unless (scroll == newScroll) $ writeTVar scrollVar newScroll