module Graphics.Vty.Widgets.CheckBox
( CheckBox
, RadioGroup
, newCheckbox
, setCheckboxUnchecked
, setCheckboxChecked
, toggleCheckbox
, onCheckboxChange
, newMultiStateCheckbox
, setCheckboxState
, cycleCheckbox
, setStateChar
, setBracketChars
, getCheckboxLabel
, getCheckboxState
, newRadioGroup
, onRadioChange
, addToRadioGroup
, getCurrentRadio
)
where
import Data.IORef
import Data.List ( findIndex )
import Data.Maybe
import qualified Data.Text as T
import Control.Monad
import Control.Exception
import Data.Typeable
import Graphics.Vty
import Graphics.Vty.Widgets.Core
import Graphics.Vty.Widgets.Text
import Graphics.Vty.Widgets.Events
import Graphics.Vty.Widgets.Util
data RadioGroupData = RadioGroupData { currentlySelected :: Maybe (Widget (CheckBox Bool))
, changeHandlers :: Handlers (Widget (CheckBox Bool))
}
type RadioGroup = IORef RadioGroupData
newRadioGroup :: IO RadioGroup
newRadioGroup = do
hs <- newHandlers
newIORef $ RadioGroupData Nothing hs
onRadioChange :: RadioGroup -> (Widget (CheckBox Bool) -> IO ())
-> IO ()
onRadioChange rg act = do
rd <- readIORef rg
addHandler (return . changeHandlers) rd act
getCurrentRadio :: RadioGroup -> IO (Maybe (Widget (CheckBox Bool)))
getCurrentRadio = (currentlySelected <~)
addToRadioGroup :: RadioGroup -> Widget (CheckBox Bool) -> IO ()
addToRadioGroup rg wRef = do
setStateChar wRef True '*'
setBracketChars wRef '(' ')'
setCheckboxUnchecked wRef
wRef `onCheckboxChange` \v ->
when v $ do
rd <- readIORef rg
fireEvent rd (return . changeHandlers) wRef
wRef `onCheckboxChange` \v ->
when v $ do
rgData <- readIORef rg
when ((isJust $ currentlySelected rgData) &&
(currentlySelected rgData /= Just wRef)) $ do
let cur = fromJust $ currentlySelected rgData
thaw cur
setChecked_ cur False
freeze wRef
writeIORef rg $ rgData { currentlySelected = Just wRef }
data CheckBoxError = EmptyCheckboxStates
| BadCheckboxState
| BadStateArgument
deriving (Show, Typeable)
instance Exception CheckBoxError
data CheckBox a = CheckBox { leftBracketChar :: Char
, rightBracketChar :: Char
, checkboxStates :: [(a, Char)]
, currentState :: a
, checkboxLabel :: T.Text
, checkboxChangeHandlers :: Handlers a
, checkboxFrozen :: Bool
, innerTextWidget :: Widget FormattedText
}
instance Show a => Show (CheckBox a) where
show cb = concat [ "CheckBox { "
, " checkboxLabel = ", show $ checkboxLabel cb
, ", checkboxStates = ", show $ checkboxStates cb
, ", currentState = ", show $ currentState cb
, ", checkboxFrozen = ", show $ checkboxFrozen cb
, " }"
]
newCheckbox :: T.Text -> IO (Widget (CheckBox Bool))
newCheckbox label = newMultiStateCheckbox label [(False, ' '), (True, 'x')]
newMultiStateCheckbox :: (Eq a) =>
T.Text
-> [(a, Char)]
-> IO (Widget (CheckBox a))
newMultiStateCheckbox _ [] = throw EmptyCheckboxStates
newMultiStateCheckbox label states = do
cchs <- newHandlers
t <- plainText ""
let initSt = CheckBox { checkboxLabel = label
, checkboxChangeHandlers = cchs
, leftBracketChar = '['
, rightBracketChar = ']'
, checkboxStates = states
, currentState = fst $ states !! 0
, checkboxFrozen = False
, innerTextWidget = t
}
wRef <- newWidget initSt $ \w ->
w { getCursorPosition_ =
\this -> do
pos <- getCurrentPosition this
ch <- leftBracketChar <~~ this
return $ Just (pos `plusWidth` (toEnum $ fromEnum $ chWidth ch))
, keyEventHandler = radioKeyEvent
, render_ =
\this sz ctx -> do
st <- getState this
tw <- innerTextWidget <~~ this
let v = currentState st
ch = fromJust $ lookup v (checkboxStates st)
s = T.concat [ T.pack [ leftBracketChar st
, ch
, rightBracketChar st
, ' '
]
, checkboxLabel st
]
setText tw s
render tw sz ctx
}
wRef `relayFocusEvents` t
setTextAppearFocused t True
return wRef
modifyElem :: [a] -> Int -> (a -> a) -> [a]
modifyElem as i f = concat [ take i as
, [f $ as !! i]
, drop (i + 1) as
]
setStateChar :: (Eq a) => Widget (CheckBox a) -> a -> Char -> IO ()
setStateChar wRef v ch = do
states <- checkboxStates <~~ wRef
let mIdx = findIndex ((== v) . fst) states
when (isNothing mIdx) $ throw BadStateArgument
let Just i = mIdx
newStates = modifyElem states i (\(k, _) -> (k, ch))
updateWidgetState wRef $ \s -> s { checkboxStates = newStates }
setBracketChars :: Widget (CheckBox a) -> Char -> Char -> IO ()
setBracketChars wRef chL chR =
updateWidgetState wRef $ \s -> s { leftBracketChar = chL
, rightBracketChar = chR
}
getCheckboxLabel :: Widget (CheckBox a) -> IO T.Text
getCheckboxLabel = (checkboxLabel <~~)
radioKeyEvent :: (Eq a) => Widget (CheckBox a) -> Key -> [Modifier] -> IO Bool
radioKeyEvent this (KASCII ' ') [] = cycleCheckbox this >> return True
radioKeyEvent this KEnter [] = cycleCheckbox this >> return True
radioKeyEvent _ _ _ = return False
setCheckboxState :: (Eq a) => Widget (CheckBox a) -> a -> IO ()
setCheckboxState = setChecked_
setCheckboxUnchecked :: Widget (CheckBox Bool) -> IO ()
setCheckboxUnchecked wRef = setCheckboxState wRef False
setCheckboxChecked :: Widget (CheckBox Bool) -> IO ()
setCheckboxChecked wRef = setCheckboxState wRef True
toggleCheckbox :: Widget (CheckBox Bool) -> IO ()
toggleCheckbox wRef = do
v <- currentState <~~ wRef
setCheckboxState wRef (not v)
getCheckboxState :: Widget (CheckBox a) -> IO a
getCheckboxState = (currentState <~~)
cycleCheckbox :: (Eq a) => Widget (CheckBox a) -> IO ()
cycleCheckbox wRef = do
v <- currentState <~~ wRef
states <- checkboxStates <~~ wRef
let Just curI = findIndex ((== v) . fst) states
nextI = (curI + 1) `mod` length states
setChecked_ wRef $ fst $ states !! nextI
setChecked_ :: (Eq a) => Widget (CheckBox a) -> a -> IO ()
setChecked_ wRef v = do
f <- checkboxFrozen <~~ wRef
when (not f) $ do
oldV <- currentState <~~ wRef
states <- checkboxStates <~~ wRef
when (not $ v `elem` (map fst states)) $
throw BadCheckboxState
when (oldV /= v) $
do
updateWidgetState wRef $ \s -> s { currentState = v }
notifyChangeHandlers wRef
notifyChangeHandlers :: Widget (CheckBox a) -> IO ()
notifyChangeHandlers wRef = do
v <- currentState <~~ wRef
fireEvent wRef (checkboxChangeHandlers <~~) v
onCheckboxChange :: Widget (CheckBox a) -> (a -> IO ()) -> IO ()
onCheckboxChange = addHandler (checkboxChangeHandlers <~~)
thaw :: Widget (CheckBox a) -> IO ()
thaw wRef = updateWidgetState wRef $ \s -> s { checkboxFrozen = False }
freeze :: Widget (CheckBox a) -> IO ()
freeze wRef = updateWidgetState wRef $ \s -> s { checkboxFrozen = True }