coin-1.0: src/Coin/UI/Widgets/Calendar.hs
{-
* Programmer: Piotr Borek
* E-mail: piotrborek@op.pl
* Copyright 2015 Piotr Borek
*
* Distributed under the terms of the GPL (GNU Public License)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module Coin.UI.Widgets.Calendar (
CalendarSize (..),
CalendarWidget,
calendarNew,
calendarGetSelectedDate,
calendarSelectDate,
calendarOnChange,
) where
import qualified System.Glib.Types as Gtk
import qualified Graphics.UI.Gtk as Gtk
import Graphics.UI.Gtk ( AttrOp(..) )
import Numeric
import Control.Monad
import Data.Maybe
import Data.IORef
import Coin.UI.Builder.GtkUIBuilder
import Coin.UI.Utils.CalendarUtils
import Coin.UI.Utils.CssUtils
import Coin.UI.Utils.Observable
import Coin.Utils.I18N
data CalendarWidget = CalendarWidget {
calendarContainer :: Gtk.Box,
calendarYearLabel :: Gtk.Label,
calendarMonthLabel :: Gtk.Label,
calendarButtons :: [Gtk.Button],
calendarYear :: IORef Integer,
calendarMonth :: IORef Int,
calendarDay :: IORef Int,
calendarSelectedYear :: IORef Integer,
calendarSelectedMonth :: IORef Int,
calendarSelectedDay :: IORef Int,
calendarChange :: Observable (Integer, Int, Int)
}
instance Gtk.GObjectClass CalendarWidget where
toGObject = Gtk.toGObject . calendarContainer
unsafeCastGObject = undefined
instance Gtk.WidgetClass CalendarWidget
data CalendarSize = CalendarSizeNormal
| CalendarSizeSmall
deriving Eq
calendarNew :: CalendarSize -> IO CalendarWidget
calendarNew calendarSize = do
(year, month, day, numberOfDays, firstDay) <- calendarGetDate
refYear <- newIORef year
refMonth <- newIORef month
refDay <- newIORef day
selectedYear <- newIORef year
selectedMonth <- newIORef month
selectedDay <- newIORef day
cal <- Gtk.calendarNew
calStyle <- Gtk.widgetGetStyle cal
bg <- colorToString <$> Gtk.styleGetBackground calStyle Gtk.StateNormal
fg <- colorToString <$> Gtk.styleGetText calStyle Gtk.StateNormal
sb <- colorToString <$> Gtk.styleGetLight calStyle Gtk.StateSelected
let css = [ cssStyleReset
, "* {"
, " color: " ++ fg ++ ";"
, "}"
, "frame {"
, " background-color: " ++ bg ++ ";"
, " border: 1px;"
, " border-style: solid;"
, " border-radius: 10px;"
, " padding: 10px 5px 10px 5px;"
, "}"
, "label {"
, " padding: 2px;"
, "}"
, "button {"
, " transition: 200ms ease-in-out;"
, if calendarSize == CalendarSizeNormal then " font-size: 1.1em;" else mempty
, " background-color: " ++ bg ++ ";"
, " border-color: " ++ bg ++ ";"
, " border-radius: 8px 0px 8px 0px;"
, " border-width: 1px;"
, " border-style: solid;"
, " padding: 2px 4px 2px 4px;"
, "}"
, "#TodayButton {"
, " transition: none;"
, if calendarSize == CalendarSizeNormal then " font-size: 1em;" else mempty
, " border-radius: 8px 0px 8px 0px;"
, " padding: 0px;"
, "}"
, "#TodayButton:active {"
, " background-color: " ++ sb ++ ";"
, "}"
, "#Arrow {"
, " font-weight: bold;"
, if calendarSize == CalendarSizeNormal then " font-size: 2em;" else mempty
, " padding: 0px;"
, " border-style: none;"
, " border-radius: 12px;"
, "}"
, "#Arrow:hover {"
, " background-color: " ++ sb ++ ";"
, "}"
, "#DayName {"
, " background-color: " ++ sb ++ ";"
, "}"
, "#Sunday {"
, " background-color: " ++ sb ++ ";"
, " font-weight: bold;"
, if calendarSize == CalendarSizeNormal then " font-size: 1.4em;" else mempty
, "}"
, "#Insensitive {"
, " border-color: " ++ bg ++ ";"
, "}"
, "#SensitiveSunday {"
, " font-weight: bold;"
, if calendarSize == CalendarSizeNormal then " font-size: 1.4em;" else mempty
, "}"
, "#Today {"
, " border-color: " ++ fg ++ ";"
, "}"
, "#TodaySunday {"
, " border-color: " ++ fg ++ ";"
, " font-weight: bold;"
, if calendarSize == CalendarSizeNormal then " font-size: 1.4em;" else mempty
, "}"
, "#TodaySelected {"
, " background-color: " ++ sb ++ ";"
, " border-color: " ++ fg ++ ";"
, "}"
, "#TodaySelectedSunday {"
, " background-color: " ++ sb ++ ";"
, " border-color: " ++ fg ++ ";"
, " font-weight: bold;"
, if calendarSize == CalendarSizeNormal then " font-size: 1.4em;" else mempty
, "}"
, "#Selected {"
, " background-color: " ++ sb ++ ";"
, "}"
, "#SelectedSunday {"
, " background-color: " ++ sb ++ ";"
, " font-weight: bold;"
, if calendarSize == CalendarSizeNormal then " font-size: 1.4em;" else mempty
, "}"
, "#TodayButton:hover,"
, "#Today:hover,"
, "#TodaySunday:hover,"
, "#TodaySelected:hover,"
, "#TodaySelectedSunday:hover,"
, "#SelectedSunday:hover,"
, "#Selected:hover,"
, "#SensitiveSunday:hover,"
, "#Sensitive:hover {"
, " border-color: " ++ sb ++ ";"
, "}"
]
(getObject, root) <- uiBuildGtk $ do
packing Gtk.PackNatural 0
vbox Nothing False 0 $ hbox Nothing False 0 $ do
globalCss css
hbox Nothing False 0 $
frame Nothing Nothing $ do
gridAttrs [ gridRowHomogeneous := True, gridColumnHomogeneous := True, Gtk.containerBorderWidth := 4 ]
grid Nothing $ do
gridAttach 0 0 1 1 $ do
buttonAttrs [ Gtk.widgetName := Just "Arrow" ]
button (Just "monthLeft") "<"
gridAttach 1 0 4 1 $ label (Just "month") (show $ intToMonth month)
gridAttach 5 0 1 1 $ do
buttonAttrs [ Gtk.widgetName := Just "Arrow" ]
button (Just "monthRight") ">"
gridAttach 7 0 1 1 $ do
buttonAttrs [ Gtk.widgetName := Just "Arrow" ]
button (Just "yearLeft") "<"
gridAttach 8 0 2 1 $ label (Just "year") (show year)
gridAttach 10 0 1 1 $ do
buttonAttrs [ Gtk.widgetName := Just "Arrow" ]
button (Just "yearRight") ">"
gridAttach 11 0 3 1 $ do
buttonAttrs [ Gtk.widgetName := Just "TodayButton" ]
button (Just "today") (__"Today")
forM_ [0 .. 13] $ \i ->
gridAttach i 1 1 1 $ do
if i `mod` 7 == 6
then labelAttrs [ Gtk.widgetName := Just "Sunday" ]
else labelAttrs [ Gtk.widgetName := Just "DayName" ]
label Nothing (show $ intToDay $ i `mod` 7)
forM_ [0 .. 13] $ \i ->
forM_ [0 .. 2] $ \j -> do
let index = j * 14 + i
gridAttach i (j + 2) 1 1 $ button (Just $ "button#" ++ show index) ""
let buttons = map (\i -> Gtk.castToButton . fromJust . getObject $ "button#" ++ show i) ([0 .. 41] :: [Int])
let monthLabel = Gtk.castToLabel . fromJust . getObject $ "month"
let yearLabel = Gtk.castToLabel . fromJust . getObject $ "year"
yearMonthObservable <- observableNew
let calendarWidget = CalendarWidget
(Gtk.castToBox root)
yearLabel
monthLabel
buttons
refYear
refMonth
refDay
selectedYear
selectedMonth
selectedDay
yearMonthObservable
let todayButton = Gtk.castToButton . fromJust . getObject $ "today"
void $ Gtk.on todayButton Gtk.buttonActivated $ do
(y, m, d, _, _) <- calendarGetDate
calendarSetSelectedDate calendarWidget y m d
calendarSelectYearMonthDay calendarWidget y m d
calendarOnChangeEmit calendarWidget
let monthLeft = Gtk.castToButton . fromJust . getObject $ "monthLeft"
void $ Gtk.on monthLeft Gtk.buttonActivated $ do
(y, m, d) <- calendarGetYearMonthDay calendarWidget
calendarSelectYearMonthDay calendarWidget y (m - 1) d
let monthRight = Gtk.castToButton . fromJust . getObject $ "monthRight"
void $ Gtk.on monthRight Gtk.buttonActivated $ do
(y, m, d) <- calendarGetYearMonthDay calendarWidget
calendarSelectYearMonthDay calendarWidget y (m + 1) d
let yearLeft = Gtk.castToButton . fromJust . getObject $ "yearLeft"
void $ Gtk.on yearLeft Gtk.buttonActivated $ do
(y, m, d) <- calendarGetYearMonthDay calendarWidget
calendarSelectYearMonthDay calendarWidget (y - 1) m d
let yearRight = Gtk.castToButton . fromJust . getObject $ "yearRight"
void $ Gtk.on yearRight Gtk.buttonActivated $ do
(y, m, d) <- calendarGetYearMonthDay calendarWidget
calendarSelectYearMonthDay calendarWidget (y + 1) m d
calendarSetSelectedDate calendarWidget year month day
calendarSetYearMonthDay calendarWidget year month day
calendarLabelButtons firstDay numberOfDays buttons
calendarSelectWidget calendarWidget
forM_ buttons $ \btn ->
void $ Gtk.on btn Gtk.buttonActivated $ do
txt <- Gtk.buttonGetLabel btn
when (txt /= []) $ do
let d = read txt
(y, m, _) <- calendarGetYearMonthDay calendarWidget
calendarSetSelectedDate calendarWidget y m d
calendarSelectWidget calendarWidget
calendarOnChangeEmit calendarWidget
return calendarWidget
where
showHex' i = let h = showHex i ""
in if length h < 2 then "0" ++ h else h
colorToString (Gtk.Color r g b) = "#" ++ showHex' (r `div` 256) ++ showHex' (g `div` 256) ++ showHex' (b `div` 256)
calendarOnChangeEmit :: CalendarWidget -> IO ()
calendarOnChangeEmit calendarWidget = do
(y, m, d) <- calendarGetSelectedDate calendarWidget
observableSet (calendarChange calendarWidget) (y, m, d)
calendarOnChange :: CalendarWidget -> (Integer -> Int -> Int -> IO ()) -> IO ()
calendarOnChange calendarWidget action =
observableRegister (calendarChange calendarWidget) $ \(year, month, day) -> action year month day
calendarSelectDate :: CalendarWidget -> (Integer, Int, Int) -> IO ()
calendarSelectDate calendarWidget (year, month, day) = do
(firstDay, numberOfDays) <- calendarGetInfo year month
calendarSelectYearMonthDay calendarWidget year month day
calendarSetSelectedDate calendarWidget year month day
calendarSetYearMonthDay calendarWidget year month day
calendarLabelButtons firstDay numberOfDays $ calendarButtons calendarWidget
calendarSelectWidget calendarWidget
calendarSelectYearMonthDay :: CalendarWidget -> Integer -> Int -> Int -> IO ()
calendarSelectYearMonthDay calendarWidget year month day = do
let (month'', year') | month < 1 = (12, year - 1)
| month > 12 = (1, year + 1)
| otherwise = (month, year)
let year'' = if year' < 0 then 0 else year'
Gtk.labelSetText (calendarYearLabel calendarWidget) $ show year''
Gtk.labelSetText (calendarMonthLabel calendarWidget) $ show (intToMonth month'')
calendarSetYearMonthDay calendarWidget year'' month'' day
(firstDay, numberOfDays) <- calendarGetInfo year'' month''
calendarLabelButtons firstDay numberOfDays $ calendarButtons calendarWidget
calendarSelectWidget calendarWidget
calendarGetYearMonthDay :: CalendarWidget -> IO (Integer, Int, Int)
calendarGetYearMonthDay calendarWidget = do
y <- readIORef $ calendarYear calendarWidget
m <- readIORef $ calendarMonth calendarWidget
d <- readIORef $ calendarDay calendarWidget
return (y, m, d)
calendarSetYearMonthDay :: CalendarWidget -> Integer -> Int -> Int -> IO ()
calendarSetYearMonthDay calendarWidget year month day = do
writeIORef (calendarYear calendarWidget) year
writeIORef (calendarMonth calendarWidget) month
writeIORef (calendarDay calendarWidget) day
calendarGetSelectedDate :: CalendarWidget -> IO (Integer, Int, Int)
calendarGetSelectedDate calendarWidget = do
y <- readIORef $ calendarSelectedYear calendarWidget
m <- readIORef $ calendarSelectedMonth calendarWidget
d <- readIORef $ calendarSelectedDay calendarWidget
return (y, m, d)
calendarSetSelectedDate :: CalendarWidget -> Integer -> Int -> Int -> IO ()
calendarSetSelectedDate calendarWidget year month day = do
writeIORef (calendarSelectedYear calendarWidget) year
writeIORef (calendarSelectedMonth calendarWidget) month
writeIORef (calendarSelectedDay calendarWidget) day
calendarLabelButtons :: Int -> Int -> [Gtk.Button] -> IO ()
calendarLabelButtons firstDay numberOfDays buttons = do
forM_ buttons $ flip Gtk.widgetSetName ""
forM_ [0 .. 41] $ \i -> do
let btn = buttons !! i
let k = i - firstDay + 2
if k > 0 && k <= numberOfDays
then do
if i `mod` 7 == 6
then Gtk.widgetSetName btn "SensitiveSunday"
else Gtk.widgetSetName btn "Sensitive"
Gtk.buttonSetLabel btn $ show k
else do
Gtk.widgetSetName btn "Insensitive"
Gtk.buttonSetLabel btn ""
calendarSelectWidget :: CalendarWidget -> IO ()
calendarSelectWidget calendarWidget = do
let buttons = calendarButtons calendarWidget
forM_ buttons $ \btn -> do
name <- Gtk.widgetGetName btn
case name of
"Today" -> Gtk.widgetSetName btn "Sensitive"
"TodaySunday" -> Gtk.widgetSetName btn "SensitiveSunday"
"TodaySelected" -> Gtk.widgetSetName btn "Sensitive"
"TodaySelectedSunday" -> Gtk.widgetSetName btn "SensitiveSunday"
"Selected" -> Gtk.widgetSetName btn "Sensitive"
"SelectedSunday" -> Gtk.widgetSetName btn "SensitiveSunday"
_ -> return ()
(year, month, _ ) <- calendarGetYearMonthDay calendarWidget
(year', month', day', _, _) <- calendarGetDate
when (year == year' && month == month') $
forM_ buttons $ \btn -> do
txt <- Gtk.buttonGetLabel btn
when (txt == show day') $ do
name <- Gtk.widgetGetName btn
case name of
"Sensitive" -> Gtk.widgetSetName btn "Today"
"SensitiveSunday" -> Gtk.widgetSetName btn "TodaySunday"
_ -> return ()
(year'', month'', day'') <- calendarGetSelectedDate calendarWidget
when (year == year'' && month == month'') $
forM_ buttons $ \btn -> do
txt <- Gtk.buttonGetLabel btn
when (txt == show day'') $ do
name <- Gtk.widgetGetName btn
case name of
"Today" -> Gtk.widgetSetName btn "TodaySelected"
"TodaySunday" -> Gtk.widgetSetName btn "TodaySelectedSunday"
"Sensitive" -> Gtk.widgetSetName btn "Selected"
"SensitiveSunday" -> Gtk.widgetSetName btn "SelectedSunday"
_ -> return ()