1+ {-# LANGUAGE BlockArguments #-}
12{-# LANGUAGE NamedFieldPuns #-}
23{-# LANGUAGE OverloadedLabels #-}
34{-# LANGUAGE OverloadedRecordDot #-}
@@ -8,19 +9,21 @@ module FF.Qt.DateComponent (DateComponent (..), new, setDate) where
89import Data.Time (Day , toGregorian )
910import Foreign.Hoppy.Runtime (toGc )
1011import Graphics.UI.Qtah.Core.QDate qualified as QDate
11- import Graphics.UI.Qtah.Core.QObject qualified as QObject
1212import Graphics.UI.Qtah.Widgets.QAbstractSpinBox qualified as QAbstractSpinBox
13- import Graphics.UI.Qtah.Widgets.QBoxLayout qualified as QBoxLayout
1413import Graphics.UI.Qtah.Widgets.QDateEdit (QDateEdit )
15- import Graphics.UI.Qtah.Widgets.QDateEdit qualified as QDateEdit
1614import Graphics.UI.Qtah.Widgets.QDateTimeEdit qualified as QDateTimeEdit
1715import Graphics.UI.Qtah.Widgets.QHBoxLayout (QHBoxLayout )
1816import Graphics.UI.Qtah.Widgets.QPushButton (QPushButton )
19- import Graphics.UI.Qtah.Widgets.QPushButton qualified as QPushButton
2017import Graphics.UI.Qtah.Widgets.QWidget qualified as QWidget
2118import Named ((!) )
2219
23- import FF.Qt.EDSL (qHBoxLayout )
20+ import FF.Qt.EDSL (
21+ QBoxLayoutItem (Widget ),
22+ qDateEdit ,
23+ qHBoxLayout ,
24+ qPushButton ,
25+ ($<) ,
26+ )
2427
2528data DateComponent = DateComponent
2629 { parent :: QHBoxLayout
@@ -31,43 +34,35 @@ data DateComponent = DateComponent
3134
3235new :: IO DateComponent
3336new = do
37+ date <-
38+ qDateEdit
39+ -- ! #calendarPopup True -- TODO bad styling on Mac
40+ ! # displayFormat " ddd d MMM yyyy"
41+ add <- qPushButton ! # objectName " set" ! # text " ➕ Set"
42+ remove <- qPushButton ! # objectName " remove" ! # text " ╳"
3443 parent <-
35- qHBoxLayout ! # objectName " [DateComponent]parent" ! # spacing 0 $ []
36-
37- date <- QDateEdit. new
38- QDateTimeEdit. setCalendarPopup date True
39- QDateTimeEdit. setDisplayFormat date " ddd d MMM yyyy"
40- QBoxLayout. addWidget parent date
41-
42- add <- QPushButton. newWithText " ➕ Set"
43- QObject. setObjectName add " set"
44- QWidget. setEnabled add False
45- QBoxLayout. addWidget parent add
46-
47- remove <- QPushButton. newWithText " ╳"
48- QObject. setObjectName remove " remove"
49- QWidget. setEnabled remove False
50- QBoxLayout. addWidget parent remove
51-
44+ qHBoxLayout ! # objectName " [DateComponent]parent" ! # spacing 0 $
45+ [Widget $< date, Widget $< add, Widget $< remove]
5246 let this = DateComponent {parent, date, add, remove}
5347 setEditable this False
5448 pure this
5549
5650setEditable :: DateComponent -> Bool -> IO ()
57- setEditable DateComponent {date} editable =
58- QAbstractSpinBox. setReadOnly date $ not editable
51+ setEditable this editable = do
52+ QAbstractSpinBox. setReadOnly this. date $ not editable
53+ QWidget. setEnabled this. add editable
54+ QWidget. setEnabled this. remove editable
5955
6056setDate :: DateComponent -> Maybe Day -> IO ()
61- setDate this day =
62- case day of
63- Just (toGregorian -> (y, m, d)) -> do
64- QWidget. show this. date
65- QWidget. hide this. add
66- QWidget. show this. remove
67- qdate <- toGc =<< QDate. newWithYmd (fromInteger y) m d
68- QDateTimeEdit. setDate this. date qdate
69- Nothing -> do
70- -- TODO replace with button "add date"
71- QWidget. hide this. date
72- QWidget. show this. add
73- QWidget. hide this. remove
57+ setDate this day = do
58+ dayIsSet <-
59+ case day of
60+ Just (toGregorian -> (y, m, d)) -> do
61+ qdate <- toGc =<< QDate. newWithYmd (fromInteger y) m d
62+ QDateTimeEdit. setDate this. date qdate
63+ pure True
64+ Nothing ->
65+ pure False
66+ QWidget. setVisible this. date dayIsSet
67+ QWidget. setVisible this. remove dayIsSet
68+ QWidget. setVisible this. add $ not dayIsSet
0 commit comments