never executed always true always false
    1 {-|
    2 Module: Flaw.Input.Mouse
    3 Description: Mouse user input.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE MultiParamTypeClasses #-}
    8 
    9 module Flaw.Input.Mouse
   10   ( MouseState(..)
   11   , MouseEvent(..)
   12   , MouseButton(..)
   13   , getMouseButtonState
   14   , getMouseCursor
   15   ) where
   16 
   17 import Control.Concurrent.STM
   18 import Data.Array.MArray
   19 
   20 import Flaw.Input
   21 
   22 data MouseState = MouseState
   23   { mouseStateButtons :: !(TArray MouseButton Bool)
   24   , mouseStateCursor :: !(TVar (Int, Int))
   25   }
   26 
   27 data MouseEvent
   28   = MouseDownEvent !MouseButton
   29   | MouseUpEvent !MouseButton
   30   | RawMouseMoveEvent !Float !Float !Float
   31   | CursorMoveEvent !Int !Int
   32   deriving Show
   33 
   34 data MouseButton
   35   = LeftMouseButton
   36   | RightMouseButton
   37   | MiddleMouseButton
   38   deriving (Eq, Ord, Ix, Bounded, Enum, Show)
   39 
   40 instance InputState MouseState where
   41   initialInputState = do
   42     buttonsArray <- newArray (minBound, maxBound) False
   43     cursorVar <- newTVar (0, 0)
   44     return MouseState
   45       { mouseStateButtons = buttonsArray
   46       , mouseStateCursor = cursorVar
   47       }
   48 
   49 instance InputDevice MouseState MouseEvent where
   50   applyInputEvent MouseState
   51     { mouseStateButtons = buttonsArray
   52     , mouseStateCursor = cursorVar
   53     } event = case event of
   54     MouseDownEvent button -> writeArray buttonsArray button True
   55     MouseUpEvent button -> writeArray buttonsArray button False
   56     RawMouseMoveEvent {} -> return ()
   57     CursorMoveEvent x y -> writeTVar cursorVar (x, y)
   58 
   59 getMouseButtonState :: MouseState -> MouseButton -> STM Bool
   60 getMouseButtonState MouseState
   61   { mouseStateButtons = buttonsArray
   62   } = readArray buttonsArray
   63 
   64 getMouseCursor :: MouseState -> STM (Int, Int)
   65 getMouseCursor MouseState
   66   { mouseStateCursor = cursorVar
   67   } = readTVar cursorVar