coin-1.0: src/Coin/UI/Widgets/MiniCalendar.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.MiniCalendar (
MiniCalendarWidget,
miniCalendarNew,
miniCalendarGetDate,
miniCalendarSetDate,
miniCalendarOnChange
) where
import qualified System.Glib.Types as Gtk
import qualified Graphics.UI.Gtk as Gtk
import Graphics.UI.Gtk ( AttrOp(..) )
import Control.Monad
import Data.Maybe
import Data.IORef
import Coin.UI.Builder.GtkUIBuilder
import Coin.UI.Utils.CssUtils
import Coin.UI.Utils.CalendarUtils
import Coin.UI.Utils.Observable
import Coin.Utils.ColorUtils
import Coin.Utils.I18N
data MiniCalendarWidget = MiniCalendarWidget {
miniCalendarContainer :: Gtk.Box,
miniCalendarYearLabel :: Gtk.Label,
miniCalendarMonthLabel :: Gtk.Label,
miniCalendarYear :: IORef Integer,
miniCalendarMonth :: IORef Int,
miniCalendarChange :: Observable (Integer, Int)
}
instance Gtk.GObjectClass MiniCalendarWidget where
toGObject = Gtk.toGObject . miniCalendarContainer
unsafeCastGObject = undefined
instance Gtk.WidgetClass MiniCalendarWidget
miniCalendarNew :: IO MiniCalendarWidget
miniCalendarNew = do
(year, month, _, _, _) <- calendarGetDate
refYear <- newIORef year
refMonth <- newIORef month
calendarObservable <- observableNew
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: 4px 4px 4px 4px;"
, "}"
, "label {"
, " padding: 2px;"
, "}"
, "button {"
, " transition: 200ms ease-in-out;"
, " font-size: 1.1em;"
, " background-color: " ++ bg ++ ";"
, " border-color: " ++ bg ++ ";"
, " border-radius: 8px 0px 8px 0px;"
, " border-width: 1px;"
, " border-style: solid;"
, " padding: 2px;"
, "}"
, "#TodayButton {"
, " transition: none;"
, " font-size: 1em;"
, " border-radius: 8px 0px 8px 0px;"
, " padding: 0px;"
, "}"
, "#TodayButton:active {"
, " background-color: " ++ sb ++ ";"
, "}"
, "#Arrow {"
, " font-weight: bold;"
, " font-size: 2em;"
, " padding: 0px 6px 0px 6px;"
, " border-style: none;"
, " border-radius: 12px;"
, "}"
, "#Arrow:hover {"
, " background-color: " ++ sb ++ ";"
, "}"
, "#TodayButton: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 $ do
frame Nothing Nothing $ do
grid Nothing $ do
gridAttach 0 0 1 1 $ do
buttonAttrs [ Gtk.widgetName := Just "Arrow" ]
button (Just "monthLeft") "<"
gridAttach 1 0 3 1 $ do
widgetAttrs [ Gtk.widgetWidthRequest := 100 ]
label (Just "month") (show $ intToMonth month)
gridAttach 4 0 1 1 $ do
buttonAttrs [ Gtk.widgetName := Just "Arrow" ]
button (Just "monthRight") ">"
gridAttach 5 0 1 1 $ do
buttonAttrs [ Gtk.widgetName := Just "Arrow" ]
button (Just "yearLeft") "<"
gridAttach 6 0 3 1 $ do
widgetAttrs [ Gtk.widgetWidthRequest := 60 ]
label (Just "year") (show year)
gridAttach 9 0 1 1 $ do
buttonAttrs [ Gtk.widgetName := Just "Arrow" ]
button (Just "yearRight") ">"
gridAttach 10 0 3 1 $ do
buttonAttrs [ Gtk.widgetName := Just "TodayButton" ]
button (Just "today") (__"Today")
let monthLabel = Gtk.castToLabel . fromJust . getObject $ "month"
let yearLabel = Gtk.castToLabel . fromJust . getObject $ "year"
let monthLeft = Gtk.castToButton . fromJust . getObject $ "monthLeft"
let monthRight = Gtk.castToButton . fromJust . getObject $ "monthRight"
let yearLeft = Gtk.castToButton . fromJust . getObject $ "yearLeft"
let yearRight = Gtk.castToButton . fromJust . getObject $ "yearRight"
let todayButton = Gtk.castToButton . fromJust . getObject $ "today"
let miniCalendarWidget = MiniCalendarWidget
(Gtk.castToBox root)
yearLabel
monthLabel
refYear
refMonth
calendarObservable
void $ Gtk.on todayButton Gtk.buttonActivated $ do
(y, m, _, _, _) <- calendarGetDate
miniCalendarSetDate miniCalendarWidget y m
void $ Gtk.on monthLeft Gtk.buttonActivated $ do
(y, m) <- miniCalendarGetDate miniCalendarWidget
miniCalendarSetDate miniCalendarWidget y (m - 1)
void $ Gtk.on monthRight Gtk.buttonActivated $ do
(y, m) <- miniCalendarGetDate miniCalendarWidget
miniCalendarSetDate miniCalendarWidget y (m + 1)
void $ Gtk.on yearLeft Gtk.buttonActivated $ do
(y, m) <- miniCalendarGetDate miniCalendarWidget
miniCalendarSetDate miniCalendarWidget (y - 1) m
void $ Gtk.on yearRight Gtk.buttonActivated $ do
(y, m) <- miniCalendarGetDate miniCalendarWidget
miniCalendarSetDate miniCalendarWidget (y + 1) m
miniCalendarSetDate miniCalendarWidget year month
return miniCalendarWidget
miniCalendarSetDate :: MiniCalendarWidget -> Integer -> Int -> IO ()
miniCalendarSetDate cal year month = do
let (month'', year') = if month < 1 then (12, year - 1) else (if month > 12 then (1, year + 1) else (month, year))
let year'' = if year' < 0 then 0 else year'
Gtk.labelSetText (miniCalendarYearLabel cal) $ show year''
Gtk.labelSetText (miniCalendarMonthLabel cal) $ show (intToMonth month'')
writeIORef (miniCalendarYear cal) year''
writeIORef (miniCalendarMonth cal) month''
observableSet (miniCalendarChange cal) (year'', month'')
miniCalendarGetDate :: MiniCalendarWidget -> IO (Integer, Int)
miniCalendarGetDate cal = do
y <- readIORef $ miniCalendarYear cal
m <- readIORef $ miniCalendarMonth cal
return (y, m)
miniCalendarOnChange :: MiniCalendarWidget -> (Integer -> Int -> IO ()) -> IO ()
miniCalendarOnChange cal action = do
observableRegister (miniCalendarChange cal) $ \(year, month) -> action year month