{- * 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.Locale.Translate import Coin.Config.Version 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 { , if gtkVersionOld then ".frame {" else "frame {" , " background-color: " ++ bg ++ ";" , " border: 1px;" , " border-style: solid;" , " border-radius: 10px;" , " padding: 10px 5px 10px 5px;" , "}" -- label { , if gtkVersionOld then ".label {" else "label {" , " padding: 2px;" , "}" , if gtkVersionOld then ".button {" else "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 #ifdef WINDOWS , " padding: 0px 4px 6px 4px;" #else , " padding: 0px;" #endif , " 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 ()