never executed always true always false
    1 {-|
    2 Module: Flaw.UI.Button
    3 Description: Button.
    4 License: MIT
    5 -}
    6 
    7 module Flaw.UI.Button
    8   ( Button(..)
    9   , newButton
   10   , newLabeledButton
   11   , setButtonDefault
   12   , setButtonCancel
   13   ) where
   14 
   15 import Control.Concurrent.STM
   16 import Control.Monad
   17 import qualified Data.Text as T
   18 
   19 import Flaw.Graphics
   20 import Flaw.Graphics.Canvas
   21 import Flaw.Input.Keyboard
   22 import Flaw.Input.Mouse
   23 import Flaw.Math
   24 import Flaw.UI
   25 import Flaw.UI.Drawer
   26 import Flaw.UI.Label
   27 
   28 data Button = Button
   29   { buttonVisual :: !SomeVisual
   30   , buttonSizeVar :: {-# UNPACK #-} !(TVar Size)
   31   , buttonFocusedVar :: !(TVar Bool)
   32   , buttonMousedVar :: !(TVar Bool)
   33   , buttonPressedVar :: !(TVar Bool)
   34   , buttonActionHandlerVar :: !(TVar (STM ()))
   35   , buttonDefaultVar :: !(TVar Bool)
   36   , buttonCancelVar :: !(TVar Bool)
   37   }
   38 
   39 newButton :: Visual v => v -> STM Button
   40 newButton visual = do
   41   sizeVar <- newTVar $ Vec2 0 0
   42   focusedVar <- newTVar False
   43   mousedVar <- newTVar False
   44   pressedVar <- newTVar False
   45   actionHandlerVar <- newTVar $ return ()
   46   defaultVar <- newTVar False
   47   cancelVar <- newTVar False
   48   return Button
   49     { buttonVisual = SomeVisual visual
   50     , buttonSizeVar = sizeVar
   51     , buttonFocusedVar = focusedVar
   52     , buttonMousedVar = mousedVar
   53     , buttonPressedVar = pressedVar
   54     , buttonActionHandlerVar = actionHandlerVar
   55     , buttonDefaultVar = defaultVar
   56     , buttonCancelVar = cancelVar
   57     }
   58 
   59 newLabeledButton :: T.Text -> STM Button
   60 newLabeledButton text = do
   61   label <- newLabel LabelStyleButton
   62   setText label text
   63   newButton label
   64 
   65 setButtonDefault :: Button -> STM ()
   66 setButtonDefault Button
   67   { buttonDefaultVar = defaultVar
   68   } = writeTVar defaultVar True
   69 
   70 setButtonCancel :: Button -> STM ()
   71 setButtonCancel Button
   72   { buttonCancelVar = cancelVar
   73   } = writeTVar cancelVar True
   74 
   75 instance Element Button where
   76 
   77   layoutElement Button
   78     { buttonSizeVar = sizeVar
   79     } = writeTVar sizeVar
   80 
   81   dabElement Button
   82     { buttonSizeVar = sizeVar
   83     } (Vec2 x y) =
   84     if x < 0 || y < 0 then return False else do
   85       size <- readTVar sizeVar
   86       let Vec2 sx sy = size
   87       return $ x < sx && y < sy
   88 
   89   renderElement Button
   90     { buttonVisual = SomeVisual visual
   91     , buttonSizeVar = sizeVar
   92     , buttonFocusedVar = focusedVar
   93     , buttonMousedVar = mousedVar
   94     , buttonPressedVar = pressedVar
   95     } drawer@Drawer
   96     { drawerCanvas = canvas
   97     , drawerStyles = DrawerStyles
   98       { drawerRaisedStyleVariant = StyleVariant
   99         { styleVariantNormalStyle = normalStyle
  100         , styleVariantMousedStyle = mousedStyle
  101         , styleVariantPressedStyle = pressedStyle
  102         }
  103       }
  104     } (Vec2 px py) = do
  105     -- get state
  106     size <- readTVar sizeVar
  107     let Vec2 sx sy = size
  108     focused <- readTVar focusedVar
  109     moused <- readTVar mousedVar
  110     pressed <- readTVar pressedVar
  111     -- get style
  112     let
  113       style
  114         | pressed = pressedStyle
  115         | moused || focused = mousedStyle
  116         | otherwise = normalStyle
  117     -- calculate visual rendering
  118     visualRender <- renderVisual visual drawer (Vec2 (px + 1) (py + 1)) size style
  119     -- return rendering monad
  120     return $ do
  121       drawBorderedRectangle canvas
  122         (Vec4 px (px + 1) (px + sx - 1) (px + sx))
  123         (Vec4 py (py + 1) (py + sy - 1) (py + sy))
  124         (styleFillColor style) (styleBorderColor style)
  125       renderIntersectScissor $ Vec4 (px + 1) (py + 1) (px + sx - 1) (py + sy - 1)
  126       renderScope visualRender
  127       when focused $ drawBorderedRectangle canvas
  128         (Vec4 (px + 3) (px + 4) (px + sx - 4) (px + sx - 3))
  129         (Vec4 (py + 3) (py + 4) (py + sy - 4) (py + sy - 3))
  130         (Vec4 0 0 0 0) (Vec4 1 1 1 0.5)
  131 
  132   processInputEvent Button
  133     { buttonMousedVar = mousedVar
  134     , buttonPressedVar = pressedVar
  135     , buttonActionHandlerVar = actionHandlerVar
  136     , buttonCancelVar = cancelVar
  137     } inputEvent _inputState = case inputEvent of
  138     KeyboardInputEvent keyboardEvent -> case keyboardEvent of
  139       KeyDownEvent key -> do
  140         press <- isPressKey key
  141         if press then do
  142           writeTVar pressedVar True
  143           return True
  144         else return False
  145       KeyUpEvent key -> do
  146         press <- isPressKey key
  147         if press then do
  148           pressed <- readTVar pressedVar
  149           when pressed $ do
  150             click
  151             writeTVar pressedVar False
  152           return True
  153         else return False
  154       _ -> return False
  155     MouseInputEvent mouseEvent -> case mouseEvent of
  156       MouseDownEvent LeftMouseButton -> do
  157         writeTVar pressedVar True
  158         return True
  159       MouseUpEvent LeftMouseButton -> do
  160         pressed <- readTVar pressedVar
  161         when pressed $ do
  162           click
  163           writeTVar pressedVar False
  164         return True
  165       CursorMoveEvent _x _y -> do
  166         writeTVar mousedVar True
  167         return True
  168       _ -> return False
  169     MouseLeaveEvent -> do
  170       writeTVar mousedVar False
  171       writeTVar pressedVar False
  172       return True
  173     where
  174       click = join $ readTVar actionHandlerVar
  175       isPressKey key = case key of
  176         KeyReturn -> return True
  177         KeySpace -> return True
  178         KeyEscape -> readTVar cancelVar
  179         _ -> return False
  180 
  181   focusElement Button
  182     { buttonFocusedVar = focusedVar
  183     } = do
  184     writeTVar focusedVar True
  185     return True
  186 
  187   unfocusElement Button
  188     { buttonFocusedVar = focusedVar
  189     , buttonPressedVar = pressedVar
  190     } = do
  191     writeTVar focusedVar False
  192     writeTVar pressedVar False
  193 
  194 instance HasActionHandler Button where
  195   setActionHandler = writeTVar . buttonActionHandlerVar