never executed always true always false
    1 {-|
    2 Module: Flaw.UI.CheckBox
    3 Description: Check box.
    4 License: MIT
    5 -}
    6 
    7 module Flaw.UI.CheckBox
    8   ( CheckBox(..)
    9   , newCheckBox
   10   , newLabeledCheckBox
   11   ) where
   12 
   13 import Control.Concurrent.STM
   14 import Control.Monad
   15 import qualified Data.Text as T
   16 
   17 import Flaw.Graphics
   18 import Flaw.Graphics.Canvas
   19 import Flaw.Input.Keyboard
   20 import Flaw.Input.Mouse
   21 import Flaw.Math
   22 import Flaw.UI
   23 import Flaw.UI.Drawer
   24 import Flaw.UI.Label
   25 import Flaw.UI.Metrics
   26 
   27 data CheckBox = CheckBox
   28   { checkBoxVisual :: !SomeVisual
   29   , checkBoxSizeVar :: !(TVar Size)
   30   , checkBoxCheckedVar :: !(TVar Bool)
   31   , checkBoxMousedVar :: !(TVar Bool)
   32   , checkBoxFocusedVar :: !(TVar Bool)
   33   , checkBoxChangeHandlerVar :: !(TVar (STM ()))
   34   }
   35 
   36 newCheckBox :: Visual v => v -> STM CheckBox
   37 newCheckBox visual = do
   38   sizeVar <- newTVar $ Vec2 0 0
   39   checkedVar <- newTVar False
   40   mousedVar <- newTVar False
   41   focusedVar <- newTVar False
   42   changeHandlerVar <- newTVar $ return ()
   43   return CheckBox
   44     { checkBoxVisual = SomeVisual visual
   45     , checkBoxSizeVar = sizeVar
   46     , checkBoxCheckedVar = checkedVar
   47     , checkBoxMousedVar = mousedVar
   48     , checkBoxFocusedVar = focusedVar
   49     , checkBoxChangeHandlerVar = changeHandlerVar
   50     }
   51 
   52 newLabeledCheckBox :: T.Text -> STM CheckBox
   53 newLabeledCheckBox text = do
   54   label <- newLabel LabelStyleText
   55   setText label text
   56   newCheckBox label
   57 
   58 instance Element CheckBox where
   59 
   60   layoutElement CheckBox
   61     { checkBoxSizeVar = sizeVar
   62     } = writeTVar sizeVar
   63 
   64   dabElement CheckBox
   65     { checkBoxSizeVar = sizeVar
   66     } (Vec2 x y) =
   67     if x < 0 || y < 0 then return False
   68     else do
   69       size <- readTVar sizeVar
   70       let
   71         Vec2 sx sy = size
   72       return $ x < sx && y < sy
   73 
   74   renderElement CheckBox
   75     { checkBoxVisual = SomeVisual visual
   76     , checkBoxSizeVar = sizeVar
   77     , checkBoxCheckedVar = checkedVar
   78     , checkBoxMousedVar = mousedVar
   79     , checkBoxFocusedVar = focusedVar
   80     } drawer@Drawer
   81     { drawerCanvas = canvas
   82     , drawerStyles = DrawerStyles
   83       { drawerLoweredStyleVariant = loweredStyleVariant
   84       , drawerRaisedStyleVariant = raisedStyleVariant
   85       }
   86     } (Vec2 px py) = do
   87     size <- readTVar sizeVar
   88     let
   89       Vec2 sx sy = size
   90     checked <- readTVar checkedVar
   91     moused <- readTVar mousedVar
   92     focused <- readTVar focusedVar
   93     let
   94       loweredStyle = (if moused || focused then styleVariantMousedStyle else styleVariantNormalStyle) loweredStyleVariant
   95       raisedStyle = (if moused then styleVariantMousedStyle else styleVariantNormalStyle) raisedStyleVariant
   96       s = min sx sy
   97       gap = s `quot` 3
   98     visualRender <- renderVisual visual drawer (Vec2 (px + s + gap) py) (Vec2 (sx - s - gap) sy) loweredStyle
   99     return $ do
  100       drawBorderedRectangle canvas
  101         (Vec4 px (px + 1) (px + s - 1) (px + s))
  102         (Vec4 py (py + 1) (py + s - 1) (py + s))
  103         (styleFillColor loweredStyle) (styleBorderColor loweredStyle)
  104       when checked $ drawBorderedRectangle canvas
  105         (Vec4 (px + gap) (px + gap + 1) (px + s - gap - 1) (px + s - gap))
  106         (Vec4 (py + gap) (py + gap + 1) (py + s - gap - 1) (py + s - gap))
  107         (styleTextColor raisedStyle) (styleBorderColor raisedStyle)
  108       renderIntersectScissor $ Vec4 (px + s + gap) py (px + sx) (py + sy)
  109       visualRender
  110 
  111   processInputEvent CheckBox
  112     { checkBoxCheckedVar = checkedVar
  113     , checkBoxMousedVar = mousedVar
  114     , checkBoxChangeHandlerVar = changeHandlerVar
  115     } inputEvent _inputState = case inputEvent of
  116     KeyboardInputEvent keyboardEvent -> case keyboardEvent of
  117       KeyDownEvent KeyReturn -> toggle
  118       KeyDownEvent KeySpace -> toggle
  119       _ -> return False
  120     MouseInputEvent (MouseDownEvent LeftMouseButton) -> toggle
  121     MouseInputEvent CursorMoveEvent {} -> do
  122       writeTVar mousedVar True
  123       return True
  124     MouseLeaveEvent -> do
  125       writeTVar mousedVar False
  126       return True
  127     _ -> return False
  128     where
  129       toggle = do
  130         modifyTVar' checkedVar not
  131         join $ readTVar changeHandlerVar
  132         return True
  133 
  134   focusElement CheckBox
  135     { checkBoxFocusedVar = focusedVar
  136     } = do
  137     writeTVar focusedVar True
  138     return True
  139 
  140   unfocusElement CheckBox
  141     { checkBoxFocusedVar = focusedVar
  142     } = writeTVar focusedVar False
  143 
  144 instance HasChecked CheckBox where
  145   setChecked CheckBox
  146     { checkBoxCheckedVar = checkedVar
  147     } = writeTVar checkedVar
  148   getChecked CheckBox
  149     { checkBoxCheckedVar = checkedVar
  150     } = readTVar checkedVar
  151 
  152 instance HasChangeHandler CheckBox where
  153   setChangeHandler CheckBox
  154     { checkBoxChangeHandlerVar = changeHandlerVar
  155     } = writeTVar changeHandlerVar
  156 
  157 instance HasPreferredSize CheckBox where
  158   preferredSize Metrics
  159     { metricsLabelSize = Vec2 _sx sy
  160     } _ = Vec2 sy sy