never executed always true always false
    1 {-|
    2 Module: Flaw.UI.Frame
    3 Description: Sub-window with header, may be moved and resized by mouse.
    4 License: MIT
    5 -}
    6 
    7 module Flaw.UI.Frame
    8   ( Frame(..)
    9   , newFrame
   10   ) where
   11 
   12 import Control.Concurrent.STM
   13 import Control.Monad
   14 import Data.Maybe
   15 import qualified Data.Text as T
   16 
   17 import Flaw.Graphics
   18 import Flaw.Graphics.Canvas
   19 import Flaw.Graphics.Font
   20 import Flaw.Graphics.Font.Render
   21 import Flaw.Input.Mouse
   22 import Flaw.Math
   23 import Flaw.UI
   24 import Flaw.UI.Drawer
   25 import Flaw.UI.Metrics
   26 import Flaw.UI.Panel
   27 
   28 data Frame = Frame
   29   { frameElement :: !SomeElement
   30   , framePanel :: !Panel
   31   , frameTextVar :: !(TVar T.Text)
   32   , frameTextScriptVar :: !(TVar FontScript)
   33   , frameFocusedVar :: !(TVar Bool)
   34   , frameFreeChildVar :: !(TVar (Maybe SomeFreeChild))
   35   , frameResizableVar :: !(TVar Bool)
   36   }
   37 
   38 -- | Create frame.
   39 -- Internally frame uses panel, and places multiple special elements on it.
   40 newFrame :: Element e => e -> Metrics -> STM Frame
   41 newFrame element Metrics
   42   { metricsFrameClient = Vec4 clientLeft clientTop clientRight clientBottom
   43   , metricsFrameTopBorder = topBorder
   44   } = do
   45   -- create panel
   46   panel@Panel
   47     { panelSizeVar = pnlSizeVar
   48     } <- newPanel True
   49 
   50   -- create vars
   51   textVar <- newTVar T.empty
   52   textScriptVar <- newTVar fontScriptUnknown
   53   focusedVar <- newTVar False
   54   freeChildVar <- newTVar Nothing
   55   resizableVar <- newTVar False
   56 
   57   -- create frame
   58   let
   59     frame = Frame
   60       { frameElement = SomeElement element
   61       , framePanel = panel
   62       , frameTextVar = textVar
   63       , frameTextScriptVar = textScriptVar
   64       , frameFocusedVar = focusedVar
   65       , frameFreeChildVar = freeChildVar
   66       , frameResizableVar = resizableVar
   67       }
   68 
   69   -- add element to panel
   70   elementChild <- addFreeChild panel element
   71 
   72   -- create resize elements
   73   let
   74     createFRE (kx, ky, kw, kh) mouseCursor = do
   75       lastMousePositionVar <- newTVar Nothing
   76       let
   77         processInput inputEvent InputState
   78           { inputStateMouse = mouseState
   79           } = case inputEvent of
   80           MouseInputEvent mouseEvent -> case mouseEvent of
   81             MouseDownEvent LeftMouseButton -> do
   82               -- if we don't have free child, don't even remember last mouse position
   83               maybeSomeFreeChild <- readTVar freeChildVar
   84               when (isJust maybeSomeFreeChild) $ do
   85                 (x, y) <- getMouseCursor mouseState
   86                 writeTVar lastMousePositionVar $ Just $ Vec2 x y
   87               return True
   88             CursorMoveEvent _x _y -> do
   89               lastMousePosition <- readTVar lastMousePositionVar
   90               case lastMousePosition of
   91                 Just (Vec2 lx ly) -> do
   92                   maybeSomeFreeChild <- readTVar freeChildVar
   93                   case maybeSomeFreeChild of
   94                     Just (SomeFreeChild freeContainer freeChild) -> do
   95                       -- check that we are resizable (or we don't need to resize anything)
   96                       resizable <- readTVar resizableVar
   97                       let needSizeChange = kw /= 0 || kh /= 0
   98                       when (resizable || not needSizeChange) $ do
   99                         (x, y) <- getMouseCursor mouseState
  100                         let
  101                           dx = x - lx
  102                           dy = y - ly
  103                         -- change position if needed
  104                         when (kx /= 0 || ky /= 0) $
  105                           placeFreeChildRelatively freeContainer freeChild $ Vec2 (dx * kx) (dy * ky)
  106                         -- change size if needed
  107                         when needSizeChange $ do
  108                           size <- readTVar pnlSizeVar
  109                           let Vec2 sx sy = size
  110                           layoutElement frame $ Vec2 (sx + dx * kw) (sy + dy * kh)
  111                         -- remember new coordinates
  112                         writeTVar lastMousePositionVar $ Just $ Vec2 x y
  113                     Nothing -> return ()
  114                   return True
  115                 Nothing -> return False
  116             MouseUpEvent LeftMouseButton -> do
  117               writeTVar lastMousePositionVar Nothing
  118               return True
  119             _ -> return False
  120           MouseLeaveEvent -> do
  121             writeTVar lastMousePositionVar Nothing
  122             return True
  123           _ -> return False
  124 
  125       sizeVar <- newTVar $ Vec2 0 0
  126       let
  127         fre = FrameResizeElement
  128           { freProcessInput = processInput
  129           , freMouseCursor = mouseCursor
  130           , freSizeVar = sizeVar
  131           , freShowCursorExp = if kw == 0 && kh == 0 then isJust <$> readTVar freeChildVar else readTVar resizableVar
  132           }
  133       freeChild <- addFreeChild panel fre
  134       return (fre, freeChild)
  135 
  136   (freNW, freNWChild) <- createFRE (1, 1, -1, -1) MouseCursorSizeNWSE
  137   (freW, freWChild) <- createFRE (1, 0, -1, 0) MouseCursorSizeWE
  138   (freSW, freSWChild) <- createFRE (1, 0, -1, 1) MouseCursorSizeNESW
  139   (freN, freNChild) <- createFRE (0, 1, 0, -1) MouseCursorSizeNS
  140   (freM, freMChild) <- createFRE (1, 1, 0, 0) MouseCursorSizeAll
  141   (freS, freSChild) <- createFRE (0, 0, 0, 1) MouseCursorSizeNS
  142   (freNE, freNEChild) <- createFRE (0, 1, 1, -1) MouseCursorSizeNESW
  143   (freE, freEChild) <- createFRE (0, 0, 1, 0) MouseCursorSizeWE
  144   (freSE, freSEChild) <- createFRE (0, 0, 1, 1) MouseCursorSizeNWSE
  145 
  146   -- set layout function
  147   setLayoutHandler panel $ \(Vec2 sx sy) -> do
  148     -- element
  149     placeFreeChild panel elementChild $ Vec2 clientLeft clientTop
  150     layoutElement element $ Vec2 (sx - clientLeft - clientRight) (sy - clientTop - clientBottom)
  151     -- NW
  152     placeFreeChild panel freNWChild $ Vec2 0 0
  153     layoutElement freNW $ Vec2 clientLeft topBorder
  154     -- W
  155     placeFreeChild panel freWChild $ Vec2 0 topBorder
  156     layoutElement freW $ Vec2 clientLeft (sy - topBorder - clientBottom)
  157     -- SW
  158     placeFreeChild panel freSWChild $ Vec2 0 (sy - clientBottom)
  159     layoutElement freSW $ Vec2 clientLeft clientBottom
  160     -- N
  161     placeFreeChild panel freNChild $ Vec2 clientLeft 0
  162     layoutElement freN $ Vec2 (sx - clientLeft - clientRight) topBorder
  163     -- M
  164     placeFreeChild panel freMChild $ Vec2 clientLeft topBorder
  165     layoutElement freM $ Vec2 (sx - clientLeft - clientRight) (clientTop - topBorder)
  166     -- S
  167     placeFreeChild panel freSChild $ Vec2 clientLeft (sy - clientBottom)
  168     layoutElement freS $ Vec2 (sx - clientLeft - clientRight) clientBottom
  169     -- NE
  170     placeFreeChild panel freNEChild $ Vec2 (sx - clientRight) 0
  171     layoutElement freNE $ Vec2 clientRight topBorder
  172     -- E
  173     placeFreeChild panel freEChild $ Vec2 (sx - clientRight) topBorder
  174     layoutElement freE $ Vec2 clientRight (sy - topBorder - clientBottom)
  175     -- SE
  176     placeFreeChild panel freSEChild $ Vec2 (sx - clientRight) (sy - clientBottom)
  177     layoutElement freSE $ Vec2 clientRight clientBottom
  178 
  179   return frame
  180 
  181 data FrameResizeElement = FrameResizeElement
  182   { freProcessInput :: !(InputEvent -> InputState -> STM Bool)
  183   , freMouseCursor :: !MouseCursor
  184   , freSizeVar :: !(TVar Int2)
  185   , freShowCursorExp :: !(STM Bool)
  186   }
  187 
  188 instance Element FrameResizeElement where
  189   layoutElement FrameResizeElement
  190     { freSizeVar = sizeVar
  191     } = writeTVar sizeVar
  192 
  193   dabElement FrameResizeElement
  194     { freSizeVar = sizeVar
  195     } (Vec2 x y) =
  196     if x < 0 || y < 0 then return False
  197     else do
  198       size <- readTVar sizeVar
  199       let Vec2 sx sy = size
  200       return $ x < sx && y < sy
  201 
  202   elementMouseCursor FrameResizeElement
  203     { freMouseCursor = mouseCursor
  204     , freShowCursorExp = showCursorExp
  205     } = do
  206     showCursor <- showCursorExp
  207     return $ if showCursor then mouseCursor else MouseCursorArrow
  208 
  209   renderElement _ _ _ = return $ return ()
  210 
  211   processInputEvent FrameResizeElement
  212     { freProcessInput = processInput
  213     } = processInput
  214 
  215 instance Element Frame where
  216 
  217   layoutElement Frame
  218     { framePanel = panel
  219     } = layoutElement panel
  220 
  221   dabElement Frame
  222     { framePanel = Panel
  223       { panelSizeVar = sizeVar
  224       }
  225     } (Vec2 x y) =
  226     if x < 0 || y < 0 then return False
  227     else do
  228       size <- readTVar sizeVar
  229       let Vec2 sx sy = size
  230       return $ x < sx && y < sy
  231 
  232   elementMouseCursor Frame
  233     { framePanel = panel
  234     } = elementMouseCursor panel
  235 
  236   renderElement Frame
  237     { framePanel = panel@Panel
  238       { panelSizeVar = sizeVar
  239       }
  240     , frameTextVar = textVar
  241     , frameTextScriptVar = textScriptVar
  242     , frameFocusedVar = focusedVar
  243     } drawer@Drawer
  244     { drawerCanvas = canvas
  245     , drawerGlyphRenderer = glyphRenderer
  246     , drawerStyles = DrawerStyles
  247       { drawerMetrics = Metrics
  248         { metricsFrameClient = Vec4 clientLeft clientTop clientRight clientBottom
  249         , metricsFrameTopBorder = topBorder
  250         }
  251       , drawerTitleFont = DrawerFont
  252         { drawerFontRenderableFontCache = renderableFontCache
  253         , drawerFontShaper = SomeFontShaper fontShaper
  254         }
  255       , drawerFrameOuterNormalStyle = outerNormalStyle
  256       , drawerFrameOuterFocusedStyle = outerFocusedStyle
  257       , drawerFrameInnerStyle = innerStyle
  258       }
  259     } (Vec2 px py) = do
  260     text <- readTVar textVar
  261     textScript <- readTVar textScriptVar
  262     focused <- readTVar focusedVar
  263     size <- readTVar sizeVar
  264     let Vec2 sx sy = size
  265     let outerStyle = if focused then outerFocusedStyle else outerNormalStyle
  266     panelRender <- renderElement panel drawer $ Vec2 px py
  267     return $ do
  268       -- draw outer frame
  269       drawBorderedRectangle canvas
  270         (Vec4 px (px + 1) (px + sx - 1) (px + sx))
  271         (Vec4 py (py + 1) (py + sy - 1) (py + sy))
  272         (styleFillColor outerStyle) (styleBorderColor outerStyle)
  273 
  274       -- render text
  275       renderGlyphs glyphRenderer renderableFontCache $
  276         renderTexts fontShaper [(text, styleTextColor outerStyle)] textScript
  277           (Vec2 (fromIntegral $ px + (sx - clientLeft - clientRight) `quot` 2) (fromIntegral $ py + topBorder + (clientTop - topBorder) `quot` 2))
  278           RenderTextCursorCenter RenderTextCursorMiddle
  279 
  280       -- draw inner frame
  281       drawBorderedRectangle canvas
  282         (Vec4 (px + clientLeft - 1) (px + clientLeft) (px + sx - clientRight) (px + sx - clientRight + 1))
  283         (Vec4 (py + clientTop - 1) (py + clientTop) (py + sy - clientBottom) (py + sy - clientBottom + 1))
  284         (styleFillColor innerStyle) (styleFillColor innerStyle)
  285 
  286       -- render panel
  287       renderScope panelRender
  288 
  289   processInputEvent Frame
  290     { framePanel = panel
  291     } = processInputEvent panel
  292 
  293   focusElement Frame
  294     { framePanel = panel
  295     , frameFocusedVar = focusedVar
  296     , frameFreeChildVar = freeChildVar
  297     } = do
  298     writeTVar focusedVar True
  299     void $ focusElement panel
  300     -- try to bring frame to top
  301     maybeSomeFreeChild <- readTVar freeChildVar
  302     case maybeSomeFreeChild of
  303       Just (SomeFreeChild container freeChild) -> bringFreeChildOnTop container freeChild
  304       Nothing -> return ()
  305     return True
  306 
  307   unfocusElement Frame
  308     { framePanel = panel
  309     , frameFocusedVar = focusedVar
  310     } = do
  311     unfocusElement panel
  312     writeTVar focusedVar False
  313 
  314 instance HasText Frame where
  315   setText Frame
  316     { frameTextVar = textVar
  317     } = writeTVar textVar
  318   setTextScript Frame
  319     { frameTextScriptVar = textScriptVar
  320     } = writeTVar textScriptVar
  321   getText Frame
  322     { frameTextVar = textVar
  323     } = readTVar textVar
  324 
  325 instance DraggableInFreeContainer Frame where
  326   setSelfFreeChild Frame
  327     { frameFreeChildVar = freeChildVar
  328     , frameResizableVar = resizableVar
  329     } container freeChild resizable = do
  330     writeTVar freeChildVar $ Just $ SomeFreeChild container freeChild
  331     writeTVar resizableVar resizable