never executed always true always false
    1 {-|
    2 Module: Flaw.UI.PileBox
    3 Description: Container element allowing user to resize child elements.
    4 License: MIT
    5 -}
    6 
    7 module Flaw.UI.PileBox
    8   ( PileBox(..)
    9   , PileBoxItem(..)
   10   , PileBoxItemDesc(..)
   11   , newPileBox
   12   ) where
   13 
   14 import Control.Concurrent.STM
   15 import Control.Monad
   16 import Control.Monad.Fix
   17 
   18 import Flaw.Input.Mouse
   19 import Flaw.Math
   20 import Flaw.UI
   21 import Flaw.UI.Metrics
   22 import Flaw.UI.Panel
   23 
   24 data PileBox = PileBox
   25   { pileBoxPanel :: !Panel
   26   , pileBoxElementsPanel :: !Panel
   27   , pileBoxItems :: ![PileBoxItem]
   28   , pileBoxItemsChildren :: ![FreeContainerChild Panel]
   29   , pileBoxGripWidth :: {-# UNPACK #-} !Metric
   30   , pileBoxHeightVar :: {-# UNPACK #-} !(TVar Metric)
   31   }
   32 
   33 data PileBoxItem = PileBoxItem
   34   { pileBoxItemParent :: !PileBox
   35   , pileBoxItemElement :: !SomeElement
   36   , pileBoxItemElementChild :: !(FreeContainerChild Panel)
   37   , pileBoxItemWidthVar :: {-# UNPACK #-} !(TVar Metric)
   38   , pileBoxItemLastMousePositionVar :: {-# UNPACK #-} !(TVar (Maybe Position))
   39   , pileBoxItemPressedVar :: {-# UNPACK #-} !(TVar Bool)
   40   }
   41 
   42 data PileBoxItemDesc = PileBoxItemDesc
   43   { pileBoxItemDescElement :: !SomeElement
   44   , pileBoxItemDescWidth :: {-# UNPACK #-} !Metric
   45   }
   46 
   47 newPileBox :: Metrics -> [PileBoxItemDesc] -> STM PileBox
   48 newPileBox Metrics
   49   { metricsPileBoxGripWidth = gripWidth
   50   } itemDescs = mfix $ \pileBox -> do
   51 
   52   -- create main panel
   53   panel <- newPanel False
   54 
   55   -- create elements panel and add elements to it
   56   elementsPanel <- newPanel False
   57   (items, itemsChildren) <- (unzip <$>) . forM itemDescs $ \PileBoxItemDesc
   58     { pileBoxItemDescElement = e@(SomeElement element)
   59     , pileBoxItemDescWidth = itemWidth
   60     }-> do
   61     elementChild <- addFreeChild elementsPanel element
   62     widthVar <- newTVar itemWidth
   63     lastMousePositionVar <- newTVar Nothing
   64     pressedVar <- newTVar False
   65     let
   66       item = PileBoxItem
   67         { pileBoxItemParent = pileBox
   68         , pileBoxItemElement = e
   69         , pileBoxItemElementChild = elementChild
   70         , pileBoxItemWidthVar = widthVar
   71         , pileBoxItemLastMousePositionVar = lastMousePositionVar
   72         , pileBoxItemPressedVar = pressedVar
   73         }
   74     -- add item to main panel
   75     itemChild <- addFreeChild panel item
   76     return (item, itemChild)
   77 
   78   -- add elements panel to main panel
   79   void $ addFreeChild panel elementsPanel
   80   -- set layout handler
   81   setLayoutHandler panel $ layoutElement elementsPanel
   82 
   83   heightVar <- newTVar 0
   84 
   85   return PileBox
   86     { pileBoxPanel = panel
   87     , pileBoxElementsPanel = elementsPanel
   88     , pileBoxItems = items
   89     , pileBoxItemsChildren = itemsChildren
   90     , pileBoxGripWidth = gripWidth
   91     , pileBoxHeightVar = heightVar
   92     }
   93 
   94 instance Element PileBox where
   95   layoutElement pileBox@PileBox
   96     { pileBoxPanel = panel
   97     , pileBoxHeightVar = heightVar
   98     } size@(Vec2 _sx sy) = do
   99     layoutElement panel size
  100     writeTVar heightVar sy
  101     relayoutPileBox pileBox
  102   dabElement = dabElement . pileBoxPanel
  103   elementMouseCursor = elementMouseCursor . pileBoxPanel
  104   renderElement = renderElement . pileBoxPanel
  105   processInputEvent = processInputEvent . pileBoxPanel
  106   focusElement = focusElement . pileBoxPanel
  107   unfocusElement = unfocusElement . pileBoxPanel
  108 
  109 instance Element PileBoxItem where
  110 
  111   layoutElement _ _ = return ()
  112 
  113   dabElement PileBoxItem
  114     { pileBoxItemParent = PileBox
  115       { pileBoxGripWidth = gripWidth
  116       , pileBoxHeightVar = heightVar
  117       }
  118     } (Vec2 x y) =
  119     if x < 0 || y < 0 || x >= gripWidth then return False
  120     else do
  121       height <- readTVar heightVar
  122       return $ y < height
  123 
  124   elementMouseCursor _ = return MouseCursorSizeWE
  125 
  126   renderElement _ _ _ = return $ return ()
  127 
  128   processInputEvent PileBoxItem
  129     { pileBoxItemParent = parent
  130     , pileBoxItemWidthVar = widthVar
  131     , pileBoxItemLastMousePositionVar = lastMousePositionVar
  132     , pileBoxItemPressedVar = pressedVar
  133     } inputEvent _inputState = case inputEvent of
  134     MouseInputEvent mouseEvent -> case mouseEvent of
  135       MouseDownEvent LeftMouseButton -> do
  136         writeTVar pressedVar True
  137         return True
  138       MouseUpEvent LeftMouseButton -> do
  139         writeTVar pressedVar False
  140         return True
  141       CursorMoveEvent x y -> do
  142         let writeLastMousePosition = writeTVar lastMousePositionVar $ Just $ Vec2 x y
  143         pressed <- readTVar pressedVar
  144         if pressed then do
  145           maybeLastMousePosition <- readTVar lastMousePositionVar
  146           case maybeLastMousePosition of
  147             Just (Vec2 lx _ly) -> do
  148               oldWidth <- readTVar widthVar
  149               let newWidth = max 0 $ oldWidth + x - lx
  150               writeTVar widthVar newWidth
  151               writeTVar lastMousePositionVar $ Just $ Vec2 (x - (newWidth - oldWidth)) y
  152               relayoutPileBox parent
  153             Nothing -> writeLastMousePosition
  154         else writeLastMousePosition
  155         return True
  156       _ -> return False
  157     MouseLeaveEvent -> do
  158       writeTVar lastMousePositionVar Nothing
  159       return True
  160     _ -> return False
  161 
  162 relayoutPileBox :: PileBox -> STM ()
  163 relayoutPileBox PileBox
  164   { pileBoxPanel = panel
  165   , pileBoxElementsPanel = elementsPanel
  166   , pileBoxItems = items
  167   , pileBoxItemsChildren = itemsChildren
  168   , pileBoxGripWidth = gripWidth
  169   , pileBoxHeightVar = heightVar
  170   } = do
  171   height <- readTVar heightVar
  172   let
  173     foldWidth totalWidth (PileBoxItem
  174       { pileBoxItemElement = SomeElement element
  175       , pileBoxItemElementChild = elementChild
  176       , pileBoxItemWidthVar = widthVar
  177       }, itemChild) = do
  178       width <- readTVar widthVar
  179       layoutElement element $ Vec2 width height
  180       placeFreeChild elementsPanel elementChild $ Vec2 totalWidth 0
  181       placeFreeChild panel itemChild $ Vec2 (totalWidth + width - gripWidth `quot` 2) 0
  182       return $ totalWidth + width
  183   foldM_ foldWidth 0 $ zip items itemsChildren