{-# LANGUAGE RecursiveDo, ImplicitParams, ScopedTypeVariables, OverloadedStrings #-}
module Graphics.UI.FLTK.Theme.Light.Spinner
(
spinnerNew,
handleSpinner,
resizeSpinner,
spinnerComponentBounds,
spinnerDownCallback,
spinnerInputCallback,
spinnerUpCallback
)
where
import Control.Exception
import Graphics.UI.FLTK.LowLevel.Dispatch
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.Theme.Light.Button
import Graphics.UI.FLTK.Theme.Light.Common
import Graphics.UI.FLTK.Theme.Light.Input
import qualified Data.Text as T
import qualified Data.Text.Read as T
import qualified Graphics.UI.FLTK.LowLevel.FL as FL
import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel
import Graphics.UI.FLTK.Theme.Light.Assets
doublePrecisionFormat :: T.Text
doublePrecisionFormat = T.pack "%.*"
spinnerComponentBounds :: Rectangle -> (Rectangle,Rectangle,Rectangle)
spinnerComponentBounds rect =
let (x',y',w',h') = fromRectangle rect
buttonH = h' `intDiv` 2
inputW = w' - buttonH - 2
buttonW = buttonH + 2
in
(
toRectangle (x',y',inputW,h'),
toRectangle (x'+inputW,y',buttonW,buttonH),
toRectangle (x'+inputW,y'+ buttonH,buttonW,buttonH)
)
handleSpinner :: Ref LowLevel.Input -> Ref LowLevel.Spinner -> Event -> IO (Either UnknownEvent ())
handleSpinner i s e =
let upOrDown = do
key <- FL.eventKey
case key of
SpecialKeyType Kb_Up -> spinnerUpCallback s i >> return (Right ())
SpecialKeyType Kb_Down -> spinnerDownCallback s i >> return (Right ())
_ -> return (Right ())
in
case e of
Keydown -> upOrDown
Shortcut -> upOrDown
_ -> LowLevel.handleSuper (safeCast s :: Ref LowLevel.Group) e
updateInput :: Maybe T.Text -> Double -> Ref LowLevel.Input -> IO ()
updateInput format v i =
let vString =
case format of
Just f -> if (doublePrecisionFormat `T.isPrefixOf` f) then show v else show (truncate v)
Nothing -> show (truncate v)
in LowLevel.setValue i (T.pack vString) >> return ()
resizeSpinner :: Ref LowLevel.Input -> Ref LowLevel.Button -> Ref LowLevel.Button -> Ref LowLevel.Spinner -> Rectangle -> IO ()
resizeSpinner i up down s r = do
LowLevel.resizeSuper (safeCast s :: Ref LowLevel.Group) r
let (iRect,upRect,downRect) = spinnerComponentBounds r
LowLevel.resize i iRect
LowLevel.resize up upRect
LowLevel.resize down downRect
spinnerInputCallback :: Ref LowLevel.Spinner -> Ref LowLevel.Input -> IO ()
spinnerInputCallback s i = do
vString <- LowLevel.getValue i
(vs :: Double) <-
case (T.decimal vString) of
Left _ ->
case (T.double vString) of
Left _ -> throwIO
(userError
("The contents of the spinner input must be an integer or floating point number: "++ (show (T.unpack vString))))
Right (v,_) -> return v
Right (v,_) -> return (fromIntegral v)
min <- LowLevel.getMinimum s
max <- LowLevel.getMaximum s
f <- LowLevel.getFormat s
let v =
if (vs < min)
then min
else if (vs > max)
then max
else vs
LowLevel.setValue s v
updateInput f v i
LowLevel.setChanged s
LowLevel.doCallback s
spinnerUpCallback :: Ref LowLevel.Spinner -> Ref LowLevel.Input -> IO ()
spinnerUpCallback s i = do
vi <- LowLevel.getValue s
min <- LowLevel.getMinimum s
max <- LowLevel.getMaximum s
step <- LowLevel.getStep s
wrap <- LowLevel.getWrap s
f <- LowLevel.getFormat s
let v =
let tmp = vi + step
in
if (tmp > max)
then if wrap then min else max
else tmp
LowLevel.setValue s v
updateInput f v i
LowLevel.setChanged s
LowLevel.doCallback s
spinnerDownCallback :: Ref LowLevel.Spinner -> Ref LowLevel.Input -> IO ()
spinnerDownCallback s i = do
vi <- LowLevel.getValue s
min <- LowLevel.getMinimum s
max <- LowLevel.getMaximum s
step <- LowLevel.getStep s
wrap <- LowLevel.getWrap s
let v =
let tmp = vi - step
in
if (tmp < min)
then if wrap then max else min
else tmp
LowLevel.setValue s v
f <- LowLevel.getFormat s
updateInput f v i
LowLevel.setChanged s
LowLevel.doCallback s
spinnerNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Spinner)
spinnerNew rect l = mdo
s <- LowLevel.spinnerCustom rect l Nothing
(Just (LowLevel.defaultCustomWidgetFuncs
{
LowLevel.handleCustom = Just (handleSpinner i),
LowLevel.resizeCustom = Just (resizeSpinner i upButton downButton)
}))
LowLevel.setColor s lightBackground
LowLevel.setBox s BorderBox
LowLevel.setTextfont s commonFont
LowLevel.setTextsize s commonFontSize
color <- commonSelectionColor
LowLevel.setSelectionColor s color
LowLevel.setLabelfont s commonFont
LowLevel.setLabelsize s commonFontSize
cs <- LowLevel.getArray s
mapM_ LowLevel.hide cs
numChildren <- LowLevel.children s
mapM_ (LowLevel.removeIndex s . AtIndex) [0 .. numChildren-1]
let (inputRect,upRect,downRect) = spinnerComponentBounds rect
LowLevel.begin s
i <- inputNew inputRect Nothing Nothing
LowLevel.setValue i "1"
LowLevel.setInputType i LowLevel.FlIntInput
LowLevel.setWhen i [WhenEnterKey, WhenRelease]
LowLevel.setCallback i (spinnerInputCallback s)
upButton <- LowLevel.buttonCustom
upRect
Nothing
(Just (\b -> do
spec <- buttonFillSpec b
r <- LowLevel.getRectangle b
s <- LowLevel.getDataSize upSmallImage
drawRegularButton (spec { fillCornerRadius = 0 }) b
LowLevel.draw upSmallImage (centerInRectangle r s)))
Nothing
buttonSetup upButton
LowLevel.setCallback upButton (\_ -> spinnerUpCallback s i)
downButton <- LowLevel.buttonCustom
downRect
Nothing
(Just (\b -> do
spec <- buttonFillSpec b
r <- LowLevel.getRectangle b
s <- LowLevel.getDataSize upSmallImage
drawRegularButton (spec { fillCornerRadius = 0 }) b
LowLevel.draw downSmallImage (centerInRectangle r s)))
Nothing
buttonSetup downButton
LowLevel.setCallback downButton (\_ -> spinnerDownCallback s i)
LowLevel.end s
return s