never executed always true always false
    1 {-|
    2 Module: Flaw.UI.Panel
    3 Description: Panel is a free container element.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE TypeFamilies #-}
    8 
    9 module Flaw.UI.Panel
   10   ( Panel(..)
   11   , newPanel
   12   ) where
   13 
   14 import Control.Monad
   15 import Control.Concurrent.STM
   16 import Data.Foldable
   17 import Data.List
   18 import Data.Maybe
   19 import qualified Data.Set as S
   20 
   21 import Flaw.Graphics
   22 import Flaw.Input.Keyboard
   23 import Flaw.Input.Mouse
   24 import Flaw.Math
   25 import Flaw.UI
   26 
   27 data Panel = Panel
   28   { panelChildrenVar :: {-# UNPACK #-} !(TVar (S.Set PanelChild))
   29   , panelChildIndexVar :: {-# UNPACK #-} !(TVar Int)
   30   , panelChildrenRenderOrderVar :: {-# UNPACK #-} !(TVar [PanelChild])
   31   , panelLayoutHandlerVar :: {-# UNPACK #-} !(TVar (Size -> STM ()))
   32   , panelSizeVar :: {-# UNPACK #-} !(TVar Size)
   33   , panelStickyFocus :: !Bool
   34   , panelFocusedChildVar :: {-# UNPACK #-} !(TVar (Maybe PanelChild))
   35   , panelLastFocusedChildVar :: {-# UNPACK #-} !(TVar (Maybe PanelChild))
   36   , panelLastMousedChildVar :: {-# UNPACK #-} !(TVar (Maybe PanelChild))
   37   , panelDefaultElementVar :: {-# UNPACK #-} !(TVar (Maybe SomeElement))
   38   , panelCancelElementVar :: {-# UNPACK #-} !(TVar (Maybe SomeElement))
   39   , panelCommitHandlerVar :: {-# UNPACK #-} !(TVar (CommitReason -> STM Bool))
   40   }
   41 
   42 data PanelChild = PanelChild
   43   { panelChildIndex :: {-# UNPACK #-} !Int
   44   , panelChildElement :: !SomeElement
   45   , panelChildPositionVar :: {-# UNPACK #-} !(TVar Position)
   46   }
   47 
   48 newPanel :: Bool -> STM Panel
   49 newPanel stickyFocus = do
   50   childrenVar <- newTVar S.empty
   51   childIndexVar <- newTVar 0
   52   childrenRenderOrderVar <- newTVar []
   53   layoutHandlerVar <- newTVar $ \_ -> return ()
   54   sizeVar <- newTVar $ Vec2 0 0
   55   focusedChildVar <- newTVar Nothing
   56   lastFocusedChildVar <- newTVar Nothing
   57   lastMousedChildVar <- newTVar Nothing
   58   defaultElementVar <- newTVar Nothing
   59   cancelElementVar <- newTVar Nothing
   60   commitHandlerVar <- newTVar $ const $ return False
   61   return Panel
   62     { panelChildrenVar = childrenVar
   63     , panelChildIndexVar = childIndexVar
   64     , panelChildrenRenderOrderVar = childrenRenderOrderVar
   65     , panelLayoutHandlerVar = layoutHandlerVar
   66     , panelSizeVar = sizeVar
   67     , panelStickyFocus = stickyFocus
   68     , panelFocusedChildVar = focusedChildVar
   69     , panelLastFocusedChildVar = lastFocusedChildVar
   70     , panelLastMousedChildVar = lastMousedChildVar
   71     , panelDefaultElementVar = defaultElementVar
   72     , panelCancelElementVar = cancelElementVar
   73     , panelCommitHandlerVar = commitHandlerVar
   74     }
   75 
   76 instance Eq PanelChild where
   77   child1 == child2 = panelChildIndex child1 == panelChildIndex child2
   78 
   79 instance Ord PanelChild where
   80   compare child1 child2 = compare (panelChildIndex child1) (panelChildIndex child2)
   81 
   82 instance Element Panel where
   83 
   84   layoutElement Panel
   85     { panelLayoutHandlerVar = layoutHandlerVar
   86     , panelSizeVar = sizeVar
   87     } size = do
   88     layoutHandler <- readTVar layoutHandlerVar
   89     layoutHandler size
   90     writeTVar sizeVar size
   91 
   92   dabElement Panel
   93     { panelChildrenVar = childrenVar
   94     , panelSizeVar = sizeVar
   95     } point@(Vec2 px py) =
   96     if px < 0 || py < 0 then return False
   97     else do
   98       size <- readTVar sizeVar
   99       let Vec2 sx sy = size
  100       if px >= sx || py >= sy then return False
  101       else let
  102         dabChildren (PanelChild
  103           { panelChildElement = SomeElement element
  104           , panelChildPositionVar = childPositionVar
  105           } : restChildren) = do
  106           childPosition <- readTVar childPositionVar
  107           r <- dabElement element $ point - childPosition
  108           if r then return True else dabChildren restChildren
  109         dabChildren [] = return False
  110         in dabChildren . S.toDescList =<< readTVar childrenVar
  111 
  112   elementMouseCursor Panel
  113     { panelLastMousedChildVar = lastMousedChildVar
  114     } = do
  115     lastMousedChild <- readTVar lastMousedChildVar
  116     case lastMousedChild of
  117       Just PanelChild
  118         { panelChildElement = SomeElement childElement
  119         } -> elementMouseCursor childElement
  120       Nothing -> return MouseCursorArrow
  121 
  122   renderElement Panel
  123     { panelChildrenRenderOrderVar = childrenRenderOrderVar
  124     , panelSizeVar = sizeVar
  125     } drawer position@(Vec2 px py) = do
  126     size <- readTVar sizeVar
  127     let Vec2 sx sy = size
  128     -- compose rendering of children
  129     childrenRenderOrder <- readTVar childrenRenderOrderVar
  130     let
  131       drawChild PanelChild
  132         { panelChildElement = SomeElement element
  133         , panelChildPositionVar = childPositionVar
  134         } = do
  135         childPosition <- readTVar childPositionVar
  136         renderScope <$> renderElement element drawer (position + childPosition)
  137     renderChildren <- foldrM (\a b -> fmap (>> b) a) (return ()) $ map drawChild childrenRenderOrder
  138     -- return
  139     return $ do
  140       renderIntersectScissor $ Vec4 px py (px + sx) (py + sy)
  141       renderChildren
  142 
  143   processInputEvent panel@Panel
  144     { panelChildrenVar = childrenVar
  145     , panelChildrenRenderOrderVar = childrenRenderOrderVar
  146     , panelStickyFocus = stickyFocus
  147     , panelFocusedChildVar = focusedChildVar
  148     , panelLastFocusedChildVar = lastFocusedChildVar
  149     , panelLastMousedChildVar = lastMousedChildVar
  150     , panelDefaultElementVar = defaultElementVar
  151     , panelCancelElementVar = cancelElementVar
  152     , panelCommitHandlerVar = commitHandlerVar
  153     } inputEvent inputState@InputState
  154     { inputStateKeyboard = keyboardState
  155     , inputStateMouse = mouseState
  156     } = case inputEvent of
  157 
  158     KeyboardInputEvent keyboardEvent -> do
  159       -- own processing: handle tab-moving focus, default and cancel elements
  160       let
  161         tryPassToDefaultElement = do
  162           defaultElement <- readTVar defaultElementVar
  163           processed <- case defaultElement of
  164             Just (SomeElement element) -> processInputEvent element inputEvent inputState
  165             Nothing -> return False
  166           if processed then return True else do
  167             commitHandler <- readTVar commitHandlerVar
  168             commitHandler CommitAccept
  169         tryPassToCancelElement = do
  170           cancelElement <- readTVar cancelElementVar
  171           processed <- case cancelElement of
  172             Just (SomeElement element) -> processInputEvent element inputEvent inputState
  173             Nothing -> return False
  174           if processed then return True else do
  175             commitHandler <- readTVar commitHandlerVar
  176             commitHandler CommitCancel
  177         moveFocus back = do
  178           focusedChild <- readTVar focusedChildVar
  179           children <- readTVar childrenVar
  180           case focusedChild of
  181             Just child@PanelChild
  182               { panelChildElement = SomeElement focusedElement
  183               } -> do
  184               let (before, after) = S.split child children
  185               focusedNewChild <- focusSomeChild panel $
  186                 if back then
  187                   S.toDescList before ++ (if stickyFocus then S.toDescList after else [])
  188                 else
  189                   S.toAscList after ++ (if stickyFocus then S.toAscList before else [])
  190               when focusedNewChild $ unfocusElement focusedElement
  191               return focusedNewChild
  192             Nothing -> focusSomeChild panel $ (if back then S.toDescList else S.toAscList) children
  193         ownProcessEvent = case keyboardEvent of
  194           KeyDownEvent KeyTab -> do
  195             keyShiftLPressed <- getKeyState keyboardState KeyShiftL
  196             keyShiftRPressed <- getKeyState keyboardState KeyShiftR
  197             moveFocus $ keyShiftLPressed || keyShiftRPressed
  198           KeyDownEvent KeyRight -> moveFocus False
  199           KeyDownEvent KeyDown -> moveFocus False
  200           KeyDownEvent KeyLeft -> moveFocus True
  201           KeyDownEvent KeyUp -> moveFocus True
  202           KeyDownEvent KeyReturn -> tryPassToDefaultElement
  203           KeyUpEvent KeyReturn -> tryPassToDefaultElement
  204           KeyDownEvent KeyEscape -> tryPassToCancelElement
  205           KeyUpEvent KeyEscape -> tryPassToCancelElement
  206           _ -> return False
  207 
  208       -- send keyboard event to focused element
  209       focusedChild <- readTVar focusedChildVar
  210       case focusedChild of
  211         Just PanelChild
  212           { panelChildElement = SomeElement element
  213           } -> do
  214           processed <- processInputEvent element inputEvent inputState
  215           if processed then return True else ownProcessEvent
  216         Nothing -> ownProcessEvent
  217 
  218     MouseInputEvent mouseEvent -> do
  219       -- send event to last moused child (without any correction)
  220       let
  221         sendToLastChild = do
  222           lastMousedChild <- readTVar lastMousedChildVar
  223           case lastMousedChild of
  224             Just PanelChild
  225               { panelChildElement = SomeElement lastMousedChildElement
  226               } -> processInputEvent lastMousedChildElement inputEvent inputState
  227             Nothing -> return False
  228       -- select by mouse event
  229       case mouseEvent of
  230         MouseDownEvent _mouseButton -> do
  231           -- focus-by-click
  232           lastMousedChild <- readTVar lastMousedChildVar
  233           case lastMousedChild of
  234             Just PanelChild
  235               { panelChildElement = SomeElement lastMousedChildElement
  236               } -> do
  237               -- get currently focused child
  238               focusedChild <- readTVar focusedChildVar
  239               -- if it's not the same one
  240               when (lastMousedChild /= focusedChild) $ do
  241                 -- try to focus element under mouse
  242                 focusAccepted <- focusElement lastMousedChildElement
  243                 when focusAccepted $ do
  244                   writeTVar focusedChildVar lastMousedChild
  245                   writeTVar lastFocusedChildVar lastMousedChild
  246                   -- unfocus previously focused child
  247                   case focusedChild of
  248                     Just PanelChild
  249                       { panelChildElement = SomeElement focusedElement
  250                       } -> unfocusElement focusedElement
  251                     Nothing -> return ()
  252               -- send mouse event in any case
  253               processInputEvent lastMousedChildElement inputEvent inputState
  254             Nothing -> return False
  255         MouseUpEvent _mouseButton -> sendToLastChild
  256         RawMouseMoveEvent _dx _dy _dz -> sendToLastChild
  257         CursorMoveEvent x y -> do
  258           -- if no mouse button is pressed, we can update "moused" child
  259           -- so we do "mouse capture" by default
  260           mousePressed <- fmap or $ forM [minBound .. maxBound] $ getMouseButtonState mouseState
  261           mousedChild <- if mousePressed then readTVar lastMousedChildVar else do
  262             -- determine child with the mouse on it
  263             let
  264               pickChild (child@PanelChild
  265                 { panelChildElement = SomeElement element
  266                 , panelChildPositionVar = childPositionVar
  267                 } : restChildren) point = do
  268                 -- correct position and ask child element
  269                 childPosition <- readTVar childPositionVar
  270                 r <- dabElement element $ point - childPosition
  271                 if r then return $ Just child else pickChild restChildren point
  272               pickChild [] _point = return Nothing
  273             childrenRenderOrder <- readTVar childrenRenderOrderVar
  274             mousedChild <- pickChild (reverse childrenRenderOrder) $ Vec2 x y
  275             -- update last moused child
  276             lastMousedChild <- readTVar lastMousedChildVar
  277             when (mousedChild /= lastMousedChild) $ do
  278               writeTVar lastMousedChildVar mousedChild
  279               case lastMousedChild of
  280                 Just PanelChild
  281                   { panelChildElement = SomeElement lastMousedChildElement
  282                   } -> void $ processInputEvent lastMousedChildElement MouseLeaveEvent inputState
  283                 Nothing -> return ()
  284             return mousedChild
  285           -- if mouse points to some element now
  286           case mousedChild of
  287             Just PanelChild
  288               { panelChildElement = SomeElement childElement
  289               , panelChildPositionVar = childPositionVar
  290               } -> do
  291               -- correct coordinates and send event
  292               size <- readTVar childPositionVar
  293               let Vec2 px py = size
  294               processInputEvent childElement (MouseInputEvent (CursorMoveEvent (x - px) (y - py))) inputState
  295             Nothing -> return False
  296     MouseLeaveEvent -> do
  297       lastMousedChild <- readTVar lastMousedChildVar
  298       case lastMousedChild of
  299         Just PanelChild
  300           { panelChildElement = SomeElement element
  301           } -> processInputEvent element MouseLeaveEvent inputState
  302         Nothing -> return False
  303 
  304   focusElement panel@Panel
  305     { panelChildrenVar = childrenVar
  306     , panelFocusedChildVar = focusedChildVar
  307     , panelLastFocusedChildVar = lastFocusedChildVar
  308     } = do
  309     focusedChild <- readTVar focusedChildVar
  310     if isNothing focusedChild then do
  311       children <- readTVar childrenVar
  312       maybeLastFocusedChild <- readTVar lastFocusedChildVar
  313       focusSomeChild panel $ case maybeLastFocusedChild of
  314         Just lastFocusedChild -> let
  315           (childrenBefore, childrenAfter) = S.split lastFocusedChild children
  316           in lastFocusedChild : S.toAscList childrenAfter ++ S.toAscList childrenBefore
  317         Nothing -> S.toAscList children
  318     else return True
  319 
  320   unfocusElement Panel
  321     { panelFocusedChildVar = focusedChildVar
  322     , panelCommitHandlerVar = commitHandlerVar
  323     } = do
  324     focusedChild <- readTVar focusedChildVar
  325     case focusedChild of
  326       Just PanelChild
  327         { panelChildElement = SomeElement element
  328         } -> do
  329         unfocusElement element
  330         writeTVar focusedChildVar Nothing
  331       Nothing -> return ()
  332     commitHandler <- readTVar commitHandlerVar
  333     void $ commitHandler CommitLostFocus
  334 
  335 instance FreeContainer Panel where
  336 
  337   type FreeContainerChild Panel = PanelChild
  338 
  339   setLayoutHandler Panel
  340     { panelLayoutHandlerVar = layoutHandlerVar
  341     , panelSizeVar = sizeVar
  342     } layoutHandler = do
  343     writeTVar layoutHandlerVar layoutHandler
  344     layoutHandler =<< readTVar sizeVar
  345 
  346   addFreeChild Panel
  347     { panelChildrenVar = childrenVar
  348     , panelChildIndexVar = childIndexVar
  349     , panelChildrenRenderOrderVar = childrenRenderOrderVar
  350     } element = do
  351     -- get index for new child
  352     childIndex <- readTVar childIndexVar
  353     writeTVar childIndexVar $ childIndex + 1
  354     -- create child
  355     positionVar <- newTVar $ Vec2 0 0
  356     let
  357       child = PanelChild
  358         { panelChildIndex = childIndex
  359         , panelChildElement = SomeElement element
  360         , panelChildPositionVar = positionVar
  361         }
  362     -- add it
  363     children <- readTVar childrenVar
  364     writeTVar childrenVar $ S.insert child children
  365     childrenRenderOrder <- readTVar childrenRenderOrderVar
  366     writeTVar childrenRenderOrderVar $ child : childrenRenderOrder
  367     -- return
  368     return child
  369 
  370   removeFreeChild panel@Panel
  371     { panelChildrenVar = childrenVar
  372     , panelChildrenRenderOrderVar = childrenRenderOrderVar
  373     , panelFocusedChildVar = focusedChildVar
  374     , panelLastFocusedChildVar = lastFocusedChildVar
  375     } child@PanelChild
  376     { panelChildElement = SomeElement element
  377     } = do
  378     children <- readTVar childrenVar
  379     -- remove from children
  380     let newChildren = S.delete child children
  381     -- removal must happen before calling `unfocusElement` to be reentrant
  382     -- because element may call `removeFreeChild` again
  383     writeTVar childrenVar newChildren
  384     -- remove from render order
  385     modifyTVar' childrenRenderOrderVar $ delete child
  386     -- if this element is focused
  387     focusedChild <- readTVar focusedChildVar
  388     when (focusedChild == Just child) $ do
  389       -- unfocus it
  390       writeTVar focusedChildVar Nothing -- before `unfocusElement` for reentrancy
  391       unfocusElement element
  392       -- try to focus some other child, starting from next one
  393       let (childrenBefore, childrenAfter) = S.split child newChildren
  394       _ <- focusSomeChild panel $ S.toAscList childrenAfter ++ S.toAscList childrenBefore
  395       return ()
  396     -- if this element was last-focused, forget it
  397     lastFocusedChild <- readTVar lastFocusedChildVar
  398     when (lastFocusedChild == Just child) $ writeTVar lastFocusedChildVar Nothing
  399 
  400   placeFreeChild _panel PanelChild
  401     { panelChildPositionVar = childPositionVar
  402     } = writeTVar childPositionVar
  403 
  404   placeFreeChildRelatively _panel PanelChild
  405     { panelChildPositionVar = childPositionVar
  406     } positionChange = modifyTVar' childPositionVar (+positionChange)
  407 
  408   bringFreeChildOnTop Panel
  409     { panelChildrenRenderOrderVar = childrenRenderOrderVar
  410     } child = modifyTVar' childrenRenderOrderVar $ (++ [child]) . delete child
  411 
  412   focusFreeChild Panel
  413     { panelFocusedChildVar = focusedChildVar
  414     , panelLastFocusedChildVar = lastFocusedChildVar
  415     } child@PanelChild
  416     { panelChildIndex = childIndex
  417     , panelChildElement = SomeElement element
  418     } = do
  419     focusedChild <- readTVar focusedChildVar
  420     case focusedChild of
  421       Just PanelChild
  422         { panelChildIndex = focusedChildIndex
  423         , panelChildElement = SomeElement focusedElement
  424         } -> when (childIndex /= focusedChildIndex) $ do
  425         focusAccepted <- focusElement element
  426         when focusAccepted $ do
  427           writeTVar focusedChildVar $ Just child
  428           writeTVar lastFocusedChildVar $ Just child
  429           unfocusElement focusedElement
  430       Nothing -> do
  431         focusAccepted <- focusElement element
  432         when focusAccepted $ do
  433           writeTVar focusedChildVar $ Just child
  434           writeTVar lastFocusedChildVar $ Just child
  435 
  436 -- | Helper function, trying to focus first child in a list accepting the focus.
  437 -- Writes index of a child accepted focus to panel.
  438 focusSomeChild :: Panel -> [PanelChild] -> STM Bool
  439 focusSomeChild Panel
  440   { panelFocusedChildVar = focusedChildVar
  441   , panelLastFocusedChildVar = lastFocusedChildVar
  442   , panelStickyFocus = stickyFocus
  443   } = tryToFocus where
  444   tryToFocus (child@PanelChild
  445     { panelChildElement = SomeElement element
  446     } : restChildren) = do
  447     focusAccepted <- focusElement element
  448     if focusAccepted then do
  449       writeTVar focusedChildVar $ Just child
  450       writeTVar lastFocusedChildVar $ Just child
  451       return True
  452     else tryToFocus restChildren
  453   tryToFocus [] = return stickyFocus
  454 
  455 instance DefaultActionRedirector Panel where
  456   setDefaultElement Panel
  457     { panelDefaultElementVar = defaultElementVar
  458     } element = writeTVar defaultElementVar $ Just $ SomeElement element
  459   setCancelElement Panel
  460     { panelCancelElementVar = cancelElementVar
  461     } element = writeTVar cancelElementVar $ Just $ SomeElement element
  462 
  463 instance HasCommitHandler Panel where
  464   setCommitHandler = writeTVar . panelCommitHandlerVar