diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,54 @@ +# Brick Calendar + +![A screenshot of the brick calendar widget](./docs/image.png) + +A calendar widget for [Brick](https://github.com/jtdaugherty/brick) terminal user interfaces. + +## Features + +- Configurable first day of week (Sunday, Monday, etc.) +- Configurable day-of-week label + - Single char (S, M, T, W, T, F, S) + - Double char (Su, Mo, Tu, We, Th, Fr, Sa) + - Distinct initials (Su, M, T, W, Th, F, S) + - Hidden +- Option to show/hide/dim days outside the current month +- Easy integration with existing Brick applications + +## Installation + +``` +cabal install brick-calendar +``` + +## Usage + +```haskell +-- Define a resource name type +data AppName = CalName CalendarResource + deriving (Show, Eq, Ord) + +-- Create a calendar state from a date +mkCalendarState :: Day -> CalendarState AppName +mkCalendarState day = + let (year, month, _) = toGregorian day + config = defaultCalendarConfig + { _weekStart = Monday + , _dayLabelStyle = DistinctInitials + , _showDayLabels = True + , _outsideMonthDisplay = ShowDimmed + } + in CalendarState year month (Just day) config CalName + +-- Render the calendar +drawUI :: AppState -> [Widget AppName] +drawUI s = [center $ border $ padAll 1 $ renderCalendar (calendar s)] + +-- Handle calendar navigation events +handleEvent :: BrickEvent AppName e -> EventM AppName AppState () +handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt +handleEvent e = + zoom calendarL $ handleCalendarEvent e +``` + +See `programs/SimpleDemo.hs` for a complete working example. diff --git a/brick-calendar.cabal b/brick-calendar.cabal --- a/brick-calendar.cabal +++ b/brick-calendar.cabal @@ -1,8 +1,10 @@ cabal-version: 3.0 name: brick-calendar -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Calendar widget for the Brick TUI library -description: A library providing a month calendar widget for Brick-based terminal user interfaces +description: + A library providing a calendar widget for -based terminal user interfaces. + See and . homepage: https://github.com/ldgrp/brick-calendar bug-reports: https://github.com/ldgrp/brick-calendar/issues license: MIT @@ -11,6 +13,7 @@ maintainer: leo@ldgrp.me category: User Interfaces, Console, TUI build-type: Simple +extra-doc-files: README.md source-repository head type: git @@ -66,6 +69,19 @@ build-depends: base >= 4.11 && < 5 ,brick-calendar ,brick >= 2.8.3 && < 2.9 + ,microlens-platform >= 0.4.4 && < 0.5 + ,time >= 1.12.2 && < 1.13 + ,vty >= 6.4 && < 6.5 + default-language: Haskell2010 + ghc-options: -Wall -threaded + +executable dual-calendar-demo + hs-source-dirs: programs + main-is: DualCalendarDemo.hs + build-depends: base >= 4.11 && < 5 + ,brick-calendar + ,brick >= 2.8.3 && < 2.9 + ,microlens-platform >= 0.4.4 && < 0.5 ,time >= 1.12.2 && < 1.13 ,vty >= 6.4 && < 6.5 default-language: Haskell2010 diff --git a/programs/CalendarDemo.hs b/programs/CalendarDemo.hs --- a/programs/CalendarDemo.hs +++ b/programs/CalendarDemo.hs @@ -3,32 +3,30 @@ module Main where import Brick -import Brick.Widgets.Core import Brick.Widgets.Border import qualified Brick.Widgets.Center as C import Brick.Widgets.Calendar -import qualified Brick.AttrMap as A import qualified Graphics.Vty as V import Data.Time -import Control.Monad import System.IO import Lens.Micro.Platform -- | Data type to identify our widgets -data Name = Calendar1 +data AppName = Calendar1 + | Calendar1Resource CalendarResource deriving (Eq, Ord, Show) -- | App state newtype AppState = AppState - { calendar :: CalendarState + { calendar :: CalendarState AppName } -- | Lens for the calendar field of AppState -calendarL :: Lens' AppState CalendarState +calendarL :: Lens' AppState (CalendarState AppName) calendarL = lens calendar (\s c -> s { calendar = c }) -- | Main app definition -app :: App AppState e CalendarResource +app :: App AppState e AppName app = App { appDraw = drawUI , appChooseCursor = showFirstCursor @@ -42,18 +40,18 @@ initialState = do today <- utctDay <$> getCurrentTime let (year, month, _) = toGregorian today - let calConfig = defaultCalendarConfig + let config = defaultCalendarConfig { _showDayLabels = True , _dayLabelStyle = DistinctInitials , _outsideMonthDisplay = ShowDimmed , _weekStart = Sunday } return AppState - { calendar = CalendarState year month (Just today) calConfig + { calendar = CalendarState year month (Just today) config Calendar1Resource } -- | Draw the UI -drawUI :: AppState -> [Widget CalendarResource] +drawUI :: AppState -> [Widget AppName] drawUI s = [C.center ((border (padAll 1 ui) <=> config) <+> hLimit 40 help)] where config = vBox @@ -81,7 +79,7 @@ ] -- | Display the current configuration -displayConfig :: CalendarState -> Widget n +displayConfig :: CalendarState AppName -> Widget n displayConfig s = let config = calConfig s weekStartText = show (config ^. weekStart) @@ -94,9 +92,7 @@ Hide -> "Hide" ShowDimmed -> "Show dimmed" ShowNormal -> "Show normal" - selectedText = case calSelectedDay s of - Nothing -> "None" - Just day -> showGregorian day + selectedText = maybe "None" showGregorian (calSelectedDay s) in withAttr (attrName "config") $ vBox [ str $ "Week starts on: " ++ weekStartText , str $ "Day label style: " ++ labelStyleText @@ -106,7 +102,7 @@ ] -- | Handle events -handleEvent :: BrickEvent CalendarResource e -> EventM CalendarResource AppState () +handleEvent :: BrickEvent AppName e -> EventM AppName AppState () handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt handleEvent (VtyEvent (V.EvKey V.KEnter [])) = halt @@ -151,26 +147,8 @@ _ -> error "Not implemented" modify $ \s -> s { calConfig = config & weekStart .~ newStart } --- Handle calendar keyboard events -handleEvent (VtyEvent (V.EvKey V.KUp [])) = calendarL %= moveUp -handleEvent (VtyEvent (V.EvKey V.KDown [])) = calendarL %= moveDown -handleEvent (VtyEvent (V.EvKey V.KLeft [])) = calendarL %= moveLeft -handleEvent (VtyEvent (V.EvKey V.KRight [])) = calendarL %= moveRight -handleEvent (VtyEvent (V.EvKey (V.KChar '[') [])) = calendarL %= setMonthBefore -handleEvent (VtyEvent (V.EvKey (V.KChar ']') [])) = calendarL %= setMonthAfter -handleEvent (VtyEvent (V.EvKey (V.KChar '{') [])) = calendarL %= setYearBefore -handleEvent (VtyEvent (V.EvKey (V.KChar '}') [])) = calendarL %= setYearAfter - --- Handle vim-like navigation -handleEvent (VtyEvent (V.EvKey (V.KChar 'h') [])) = calendarL %= moveLeft -handleEvent (VtyEvent (V.EvKey (V.KChar 'j') [])) = calendarL %= moveDown -handleEvent (VtyEvent (V.EvKey (V.KChar 'k') [])) = calendarL %= moveUp -handleEvent (VtyEvent (V.EvKey (V.KChar 'l') [])) = calendarL %= moveRight -handleEvent (VtyEvent (V.EvKey (V.KChar 'H') [])) = calendarL %= setMonthBefore -handleEvent (VtyEvent (V.EvKey (V.KChar 'L') [])) = calendarL %= setMonthAfter -handleEvent (VtyEvent (V.EvKey (V.KChar 'J') [])) = calendarL %= setYearBefore -handleEvent (VtyEvent (V.EvKey (V.KChar 'K') [])) = calendarL %= setYearAfter -handleEvent _ = return () +-- Use the default calendar event handler for navigation +handleEvent e = zoom calendarL $ handleCalendarEvent e -- | Main function main :: IO () diff --git a/programs/DualCalendarDemo.hs b/programs/DualCalendarDemo.hs new file mode 100644 --- /dev/null +++ b/programs/DualCalendarDemo.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Brick +import Brick.Widgets.Border +import qualified Brick.Widgets.Center as C +import Brick.Widgets.Calendar +import qualified Graphics.Vty as V +import Data.Time +import System.IO +import Lens.Micro.Platform + +data AppName = + Calendar1 CalendarResource -- ^ Resources for first calendar + | Calendar2 CalendarResource -- ^ Resources for second calendar + deriving (Show, Eq, Ord) + +data ActiveCalendar = ActiveCalendar1 | ActiveCalendar2 + deriving (Eq) + +-- | Application state with two calendars +data AppState = AppState + { calendar1 :: CalendarState AppName -- ^ Left calendar + , calendar2 :: CalendarState AppName -- ^ Right calendar + , activeCalendar :: ActiveCalendar -- ^ Currently active calendar + } + +calendar1L :: Lens' AppState (CalendarState AppName) +calendar1L = lens calendar1 (\s a -> s { calendar1 = a }) + +calendar2L :: Lens' AppState (CalendarState AppName) +calendar2L = lens calendar2 (\s a -> s { calendar2 = a }) + +activeCalendarL :: Lens' AppState ActiveCalendar +activeCalendarL = lens activeCalendar (\s a -> s { activeCalendar = a }) + +-- | Initialize a calendar state for the first (left) calendar +mkCalendar1 :: Day -> CalendarState AppName +mkCalendar1 day = + let (year, month, _) = toGregorian day + config = defaultCalendarConfig + { _showDayLabels = True + , _dayLabelStyle = DistinctInitials + , _outsideMonthDisplay = ShowDimmed + , _weekStart = Monday + } + in CalendarState year month (Just day) config Calendar1 + +-- | Initialize a calendar state for the second (right) calendar +mkCalendar2 :: Day -> CalendarState AppName +mkCalendar2 day = + let (year, month, _) = toGregorian day + config = defaultCalendarConfig + { _showDayLabels = True + , _dayLabelStyle = DoubleChar + , _outsideMonthDisplay = ShowNormal + , _weekStart = Sunday + } + in CalendarState year month (Just day) config Calendar2 + +-- | Main app definition +app :: App AppState e AppName +app = App + { appDraw = drawUI + , appChooseCursor = showFirstCursor + , appHandleEvent = handleEvent + , appStartEvent = return () + , appAttrMap = const defaultCalendarAttrMap + } + +-- | Draw the UI with both calendars side-by-side +drawUI :: AppState -> [Widget AppName] +drawUI s = + let + -- Apply highlight to the active calendar + cal1Border = if activeCalendar s == ActiveCalendar1 + then withAttr (attrName "active") . border + else withAttr (attrName "inactive") . border + + cal2Border = if activeCalendar s == ActiveCalendar2 + then withAttr (attrName "active") . border + else withAttr (attrName "inactive") . border + + cal1Widget = cal1Border $ padAll 1 $ renderCalendar (calendar1 s) + cal2Widget = cal2Border $ padAll 1 $ renderCalendar (calendar2 s) + + -- The main layout + mainLayout = vBox + [ C.hCenter $ str "Tab to switch focus" + , hBorder + ,C.hCenter $ hBox [C.center cal1Widget, vBorder, C.center cal2Widget] + ] + in [C.center mainLayout] + +-- | Handle events for both calendars +handleEvent :: BrickEvent AppName e -> EventM AppName AppState () +handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt +handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt + +-- Tab key switches focus between calendars +handleEvent (VtyEvent (V.EvKey (V.KChar '\t') [])) = do + modify $ \s -> s { activeCalendar = if activeCalendar s == ActiveCalendar1 then ActiveCalendar2 else ActiveCalendar1 } + +-- Handle calendar events for the active calendar +handleEvent e = do + active <- use activeCalendarL + case active of + ActiveCalendar1 -> zoom calendar1L $ handleCalendarEvent e + ActiveCalendar2 -> zoom calendar2L $ handleCalendarEvent e + +-- | Main function +main :: IO () +main = do + -- Ensure unicode support + hSetEncoding stdout utf8 + + -- Get today's date and one month later for the two calendars + today <- utctDay <$> getCurrentTime + let nextMonth = addGregorianMonthsClip 1 today + + -- Create initial state with two calendars + let initialState = AppState + { calendar1 = mkCalendar1 today + , calendar2 = mkCalendar2 nextMonth + , activeCalendar = ActiveCalendar1 -- First calendar is active initially + } + + -- Run the app + finalState <- defaultMain app initialState + + -- Print the selected dates when the app exits + putStrLn "Calendar 1 selected date: " + case calSelectedDay $ calendar1 finalState of + Just day -> putStrLn $ showGregorian day + Nothing -> putStrLn "No date selected" + + putStrLn "Calendar 2 selected date: " + case calSelectedDay $ calendar2 finalState of + Just day -> putStrLn $ showGregorian day + Nothing -> putStrLn "No date selected" diff --git a/programs/SimpleDemo.hs b/programs/SimpleDemo.hs --- a/programs/SimpleDemo.hs +++ b/programs/SimpleDemo.hs @@ -6,19 +6,24 @@ import Brick.Widgets.Border import qualified Brick.Widgets.Center as C import Brick.Widgets.Calendar -import qualified Brick.AttrMap as A import qualified Graphics.Vty as V import Data.Time -import Control.Monad import System.IO +import Lens.Micro.Platform --- App state with calendar +data AppName = CalName CalendarResource + deriving (Show, Eq, Ord) + +calendarL :: Lens' AppState (CalendarState AppName) +calendarL = lens calendar (\s a -> s { calendar = a }) + +-- | App state with calendar newtype AppState = AppState - { calendar :: CalendarState + { calendar :: CalendarState AppName } -- Initialize the app state -mkCalendarState :: Day -> CalendarState +mkCalendarState :: Day -> CalendarState AppName mkCalendarState day = let (year, month, _) = toGregorian day config = defaultCalendarConfig @@ -27,10 +32,10 @@ , _outsideMonthDisplay = ShowDimmed , _weekStart = Sunday } - in CalendarState year month (Just day) config + in CalendarState year month (Just day) config CalName -- Main app definition -app :: App AppState e CalendarResource +app :: App AppState e AppName app = App { appDraw = drawUI , appChooseCursor = showFirstCursor @@ -40,30 +45,17 @@ } -- Draw the UI -drawUI :: AppState -> [Widget CalendarResource] +drawUI :: AppState -> [Widget AppName] drawUI s = [C.center $ border $ padAll 1 $ renderCalendar (calendar s)] --- Handle events -handleEvent :: BrickEvent CalendarResource e -> EventM CalendarResource AppState () +-- | Handle events +handleEvent :: BrickEvent AppName e -> EventM AppName AppState () handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt -handleEvent (VtyEvent (V.EvKey V.KUp [])) = - modify $ \s -> s { calendar = moveUp (calendar s) } -handleEvent (VtyEvent (V.EvKey V.KDown [])) = - modify $ \s -> s { calendar = moveDown (calendar s) } -handleEvent (VtyEvent (V.EvKey V.KLeft [])) = - modify $ \s -> s { calendar = moveLeft (calendar s) } -handleEvent (VtyEvent (V.EvKey V.KRight [])) = - modify $ \s -> s { calendar = moveRight (calendar s) } -handleEvent (VtyEvent (V.EvKey (V.KChar '[') [])) = - modify $ \s -> s { calendar = setMonthBefore (calendar s) } -handleEvent (VtyEvent (V.EvKey (V.KChar ']') [])) = - modify $ \s -> s { calendar = setMonthAfter (calendar s) } -handleEvent (VtyEvent (V.EvKey (V.KChar '{') [])) = - modify $ \s -> s { calendar = setYearBefore (calendar s) } -handleEvent (VtyEvent (V.EvKey (V.KChar '}') [])) = - modify $ \s -> s { calendar = setYearAfter (calendar s) } -handleEvent _ = return () + +-- Use the built-in calendar event handler for navigation +handleEvent e = do + zoom calendarL $ handleCalendarEvent e -- Main function main :: IO () diff --git a/src/Brick/Widgets/Calendar.hs b/src/Brick/Widgets/Calendar.hs --- a/src/Brick/Widgets/Calendar.hs +++ b/src/Brick/Widgets/Calendar.hs @@ -35,7 +35,10 @@ , setYearBefore , setYearAfter - -- * Configuration + -- * Pre-built event handler + , handleCalendarEvent + + -- * Configuration , CalendarConfig(..) , DayLabelStyle(..) , OutsideMonthDisplay(..) diff --git a/src/Brick/Widgets/Calendar/Internal/Actions.hs b/src/Brick/Widgets/Calendar/Internal/Actions.hs --- a/src/Brick/Widgets/Calendar/Internal/Actions.hs +++ b/src/Brick/Widgets/Calendar/Internal/Actions.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE LambdaCase #-} + module Brick.Widgets.Calendar.Internal.Actions - ( moveUp + ( -- * Navigation actions + moveUp , moveDown , moveLeft , moveRight @@ -7,46 +10,51 @@ , setMonthAfter , setYearBefore , setYearAfter + -- * Event handler for common calendar navigation + -- You can also use the individual actions above to create your own custom event handler + , handleCalendarEvent ) where import Data.Time import Data.Time.Calendar.Month +import Brick ( modify, EventM, BrickEvent(..) ) +import qualified Graphics.Vty as V import Brick.Widgets.Calendar.Internal.Core -moveUp :: CalendarState -> CalendarState +moveUp :: CalendarState n -> CalendarState n moveUp = navigateSelection (addDays (-7)) -moveDown :: CalendarState -> CalendarState +moveDown :: CalendarState n -> CalendarState n moveDown = navigateSelection (addDays 7) -moveLeft :: CalendarState -> CalendarState +moveLeft :: CalendarState n -> CalendarState n moveLeft = navigateSelection (addDays (-1)) -moveRight :: CalendarState -> CalendarState +moveRight :: CalendarState n -> CalendarState n moveRight = navigateSelection (addDays 1) -setMonthBefore :: CalendarState -> CalendarState +setMonthBefore :: CalendarState n -> CalendarState n setMonthBefore = navigateMonth (addMonths (-1)) -setMonthAfter :: CalendarState -> CalendarState +setMonthAfter :: CalendarState n -> CalendarState n setMonthAfter = navigateMonth (addMonths 1) -setYearBefore :: CalendarState -> CalendarState +setYearBefore :: CalendarState n -> CalendarState n setYearBefore = navigateMonth (addMonths (-12)) -setYearAfter :: CalendarState -> CalendarState +setYearAfter :: CalendarState n -> CalendarState n setYearAfter = navigateMonth (addMonths 12) -navigateSelection :: (Day -> Day) -> CalendarState -> CalendarState +navigateSelection :: (Day -> Day) -> CalendarState n -> CalendarState n navigateSelection dayTransform s = case calSelectedDay s of Nothing -> @@ -61,7 +69,7 @@ -- Otherwise just update the selected day else s { calSelectedDay = Just newDay } -navigateMonth :: (Month -> Month) -> CalendarState -> CalendarState +navigateMonth :: (Month -> Month) -> CalendarState n -> CalendarState n navigateMonth monthTransform s = let currentYM = YearMonth (calYear s) (calMonth s) newYM = monthTransform currentYM @@ -77,3 +85,29 @@ in Just $ fromGregorian newYear newMonth adjustedDay in s { calYear = newYear, calMonth = newMonth, calSelectedDay = newDay } + +handleCalendarEvent :: BrickEvent n e -> EventM n (CalendarState n) () +handleCalendarEvent = \case + -- Navigate between days + VtyEvent (V.EvKey V.KUp []) -> modify moveUp + VtyEvent (V.EvKey V.KDown []) -> modify moveDown + VtyEvent (V.EvKey V.KLeft []) -> modify moveLeft + VtyEvent (V.EvKey V.KRight []) -> modify moveRight + VtyEvent (V.EvKey (V.KChar 'h') []) -> modify moveLeft + VtyEvent (V.EvKey (V.KChar 'l') []) -> modify moveRight + VtyEvent (V.EvKey (V.KChar 'j') []) -> modify moveDown + VtyEvent (V.EvKey (V.KChar 'k') []) -> modify moveUp + + -- Navigate between months + VtyEvent (V.EvKey (V.KChar '[') []) -> modify setMonthBefore + VtyEvent (V.EvKey (V.KChar ']') []) -> modify setMonthAfter + VtyEvent (V.EvKey (V.KChar 'H') []) -> modify setMonthBefore + VtyEvent (V.EvKey (V.KChar 'L') []) -> modify setMonthAfter + + -- Navigate between years + VtyEvent (V.EvKey (V.KChar '{') []) -> modify setYearBefore + VtyEvent (V.EvKey (V.KChar '}') []) -> modify setYearAfter + VtyEvent (V.EvKey (V.KChar 'J') []) -> modify setYearBefore + VtyEvent (V.EvKey (V.KChar 'K') []) -> modify setYearAfter + + _ -> return () diff --git a/src/Brick/Widgets/Calendar/Internal/Core.hs b/src/Brick/Widgets/Calendar/Internal/Core.hs --- a/src/Brick/Widgets/Calendar/Internal/Core.hs +++ b/src/Brick/Widgets/Calendar/Internal/Core.hs @@ -76,13 +76,12 @@ deriving (Show, Eq, Ord) -- | The state of the calendar widget. Make this part of your application state. -data CalendarState = CalendarState - { calYear :: Integer -- ^ Current year - , calMonth :: Int -- ^ Current month (1-12) - , calSelectedDay :: Maybe Day -- ^ Currently selected day, if any - , calConfig :: CalendarConfig -- ^ Calendar configuration - } deriving (Show, Eq) - - +data CalendarState n = CalendarState + { calYear :: Integer -- ^ Current year + , calMonth :: Int -- ^ Current month (1-12) + , calSelectedDay :: Maybe Day -- ^ Currently selected day, if any + , calConfig :: CalendarConfig -- ^ Calendar configuration + , calendarName :: CalendarResource -> n -- ^ Constructor for wrapping calendar resources in the application's resource name type + } makeLenses ''CalendarConfig diff --git a/src/Brick/Widgets/Calendar/Internal/Month.hs b/src/Brick/Widgets/Calendar/Internal/Month.hs --- a/src/Brick/Widgets/Calendar/Internal/Month.hs +++ b/src/Brick/Widgets/Calendar/Internal/Month.hs @@ -17,31 +17,31 @@ import Brick.Widgets.Calendar.Internal.Utils -- | Render a month calendar widget -renderCalendar :: CalendarState -> Widget CalendarResource +renderCalendar :: Ord n => CalendarState n -> Widget n renderCalendar state@CalendarState{..} = vBox [ renderHeader state , if calConfig ^. showDayLabels then renderDayLabels calConfig else emptyWidget - , renderDays calConfig calYear calMonth calSelectedDay + , renderDays calConfig calYear calMonth calSelectedDay calendarName ] -- | Render the calendar header with month/year and navigation buttons -renderHeader :: CalendarState -> Widget CalendarResource +renderHeader :: Ord n => CalendarState n -> Widget n renderHeader CalendarState{..} = let monthText = getMonthLabel calConfig calYear calMonth - prevButton = clickable CalendarPrev $ + prevButton = clickable (calendarName CalendarPrev) $ withAttr (attrName "calendar.nav") $ str " << " - monthLabel = clickable (CalendarMonth (fromIntegral calYear) calMonth) $ + monthLabel = clickable (calendarName (CalendarMonth (fromIntegral calYear) calMonth)) $ txt monthText - nextButton = clickable CalendarNext $ + nextButton = clickable (calendarName CalendarNext) $ withAttr (attrName "calendar.nav") $ str " >> " in hLimit 20 $ hCenter $ hBox [prevButton, monthLabel, nextButton] -- | Render the day labels (S M T W T F S) -renderDayLabels :: CalendarConfig -> Widget CalendarResource +renderDayLabels :: CalendarConfig -> Widget n renderDayLabels config = let labels = getWeekDayLabels config -- Create evenly spaced day labels using padRight @@ -52,8 +52,8 @@ in hBox $ map makeLabel paddedLabels -- | Render the days of the month -renderDays :: CalendarConfig -> Integer -> Int -> Maybe Day -> Widget CalendarResource -renderDays config year month selectedDay = +renderDays :: Ord n => CalendarConfig -> Integer -> Int -> Maybe Day -> (CalendarResource -> n) -> Widget n +renderDays config year month selectedDay nameF = let yearMonth = YearMonth year month daysInMonth = periodLength yearMonth firstDay = getFirstDayOfMonth year month @@ -84,7 +84,6 @@ YearMonth nextYear nextMonth = nextYearMonth -- Calculate days needed for a standard 6-row calendar (42 days total) - -- Direct calculation without intermediate variables totalDays = length prevDays + length currentDays daysNeeded = 42 - totalDays -- 6 rows × 7 days @@ -122,7 +121,7 @@ else formatDayNumber config day -- Create clickable day widget with appropriate resource identifier - baseDayWidget = clickable (CalendarDay (fromIntegral y) m d) $ + baseDayWidget = clickable (nameF (CalendarDay (fromIntegral y) m d)) $ hLimit 3 $ withAttr finalAttr (txt dayText) -- Add padding except for the last item in each row diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -8,7 +8,7 @@ main = hspec $ do describe "Calendar Navigation" $ do let standardState year month day = - CalendarState year month (Just $ fromGregorian year month day) defaultCalendarConfig + CalendarState year month (Just $ fromGregorian year month day) defaultCalendarConfig id describe "Directional Movement" $ do it "correctly moves selection up" $ do