brick-calendar (empty) → 0.1.0.0
raw patch · 11 files changed
+965/−0 lines, 11 filesdep +basedep +brickdep +brick-calendarsetup-changed
Dependencies added: base, brick, brick-calendar, hspec, microlens, microlens-platform, microlens-th, text, time, vector, vty
Files
- LICENSE +21/−0
- Setup.hs +2/−0
- brick-calendar.cabal +72/−0
- programs/CalendarDemo.hs +186/−0
- programs/SimpleDemo.hs +84/−0
- src/Brick/Widgets/Calendar.hs +82/−0
- src/Brick/Widgets/Calendar/Internal/Actions.hs +79/−0
- src/Brick/Widgets/Calendar/Internal/Core.hs +88/−0
- src/Brick/Widgets/Calendar/Internal/Month.hs +139/−0
- src/Brick/Widgets/Calendar/Internal/Utils.hs +100/−0
- test/Main.hs +112/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2025 Leo Orpilla III++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ brick-calendar.cabal view
@@ -0,0 +1,72 @@+cabal-version: 3.0+name: brick-calendar+version: 0.1.0.0+synopsis: Calendar widget for the Brick TUI library+description: A library providing a month calendar widget for Brick-based terminal user interfaces+homepage: https://github.com/ldgrp/brick-calendar+bug-reports: https://github.com/ldgrp/brick-calendar/issues+license: MIT+license-file: LICENSE+author: Leo Orpilla III+maintainer: leo@ldgrp.me+category: User Interfaces, Console, TUI+build-type: Simple++source-repository head+ type: git+ location: https://github.com/ldgrp/brick-calendar.git+ branch: main++library+ hs-source-dirs: src+ exposed-modules: Brick.Widgets.Calendar+ other-modules: Brick.Widgets.Calendar.Internal.Core+ ,Brick.Widgets.Calendar.Internal.Month+ ,Brick.Widgets.Calendar.Internal.Utils+ ,Brick.Widgets.Calendar.Internal.Actions+ build-depends: base >= 4.11 && < 5+ ,brick >= 2.8.3 && < 2.9+ ,vty >= 6.4 && < 6.5+ ,time >= 1.12.2 && < 1.13+ ,text >= 2.0.2 && < 2.1+ ,vector >= 0.13.2 && < 0.14+ ,microlens >= 0.4.14 && < 0.5+ ,microlens-th >= 0.4.3 && < 0.5+ default-language: Haskell2010+ ghc-options: -Wall++test-suite brick-calendar-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: base >= 4.11 && < 5+ ,brick-calendar+ ,brick >= 2.8.3 && < 2.9+ ,vty >= 6.4 && < 6.5+ ,time >= 1.12.2 && < 1.13+ ,hspec+ default-language: Haskell2010+ ghc-options: -Wall++executable calendar-demo+ hs-source-dirs: programs+ main-is: CalendarDemo.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+ ghc-options: -Wall -threaded ++executable simple-demo+ hs-source-dirs: programs+ main-is: SimpleDemo.hs+ build-depends: base >= 4.11 && < 5+ ,brick-calendar+ ,brick >= 2.8.3 && < 2.9+ ,time >= 1.12.2 && < 1.13+ ,vty >= 6.4 && < 6.5+ default-language: Haskell2010+ ghc-options: -Wall -threaded
+ programs/CalendarDemo.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE OverloadedStrings #-}++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+ deriving (Eq, Ord, Show)++-- | App state+newtype AppState = AppState+ { calendar :: CalendarState+ }++-- | Lens for the calendar field of AppState+calendarL :: Lens' AppState CalendarState+calendarL = lens calendar (\s c -> s { calendar = c })++-- | Main app definition+app :: App AppState e CalendarResource+app = App+ { appDraw = drawUI+ , appChooseCursor = showFirstCursor+ , appHandleEvent = handleEvent+ , appStartEvent = return ()+ , appAttrMap = const defaultCalendarAttrMap+ }++-- | Initialize the app state+initialState :: IO AppState+initialState = do+ today <- utctDay <$> getCurrentTime+ let (year, month, _) = toGregorian today+ let calConfig = defaultCalendarConfig+ { _showDayLabels = True+ , _dayLabelStyle = DistinctInitials+ , _outsideMonthDisplay = ShowDimmed+ , _weekStart = Sunday+ }+ return AppState+ { calendar = CalendarState year month (Just today) calConfig+ }++-- | Draw the UI+drawUI :: AppState -> [Widget CalendarResource]+drawUI s = [C.center ((border (padAll 1 ui) <=> config) <+> hLimit 40 help)]+ where+ config = vBox+ [+ displayConfig (calendar s)+ ]+ ui =+ padAll 1 $ renderCalendar (calendar s)+ help = vBox+ [ str "Controls"+ , hBorder+ , str "Navigation:"+ , str "arrow keys / hjkl - move selection"+ , str "[] / HL - previous / next month"+ , str "{} / JK - previous / next year"+ , hBorder+ , str "Settings:"+ , str "d - toggle day labels"+ , str "t - cycle label style"+ , str "o - cycle outside days"+ , str "w - toggle week start"+ , hBorder+ , str "Actions:"+ , str "Enter / Esc / q - select date and exit"+ ]++-- | Display the current configuration+displayConfig :: CalendarState -> Widget n+displayConfig s =+ let config = calConfig s+ weekStartText = show (config ^. weekStart)+ labelStyleText = case config ^. dayLabelStyle of+ SingleChar -> "Single char"+ DoubleChar -> "Double char"+ DistinctInitials -> "Thursday as Th"+ showLabelsText = if config ^. showDayLabels then "Show" else "Hide"+ outsideText = case config ^. outsideMonthDisplay of+ Hide -> "Hide"+ ShowDimmed -> "Show dimmed"+ ShowNormal -> "Show normal"+ selectedText = case calSelectedDay s of+ Nothing -> "None"+ Just day -> showGregorian day+ in withAttr (attrName "config") $+ vBox [ str $ "Week starts on: " ++ weekStartText+ , str $ "Day label style: " ++ labelStyleText+ , str $ "Day labels: " ++ showLabelsText+ , str $ "Outside month days: " ++ outsideText+ , str $ "Selected day: " ++ selectedText+ ]++-- | Handle events+handleEvent :: BrickEvent CalendarResource e -> EventM CalendarResource AppState ()+handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt+handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt+handleEvent (VtyEvent (V.EvKey V.KEnter [])) = halt++-- Toggle day labels+handleEvent (VtyEvent (V.EvKey (V.KChar 'd') [])) = do+ zoom calendarL $ do+ cal <- get+ let config = calConfig cal+ modify $ \s -> s { calConfig = config & showDayLabels %~ not }++-- Cycle day label style+handleEvent (VtyEvent (V.EvKey (V.KChar 't') [])) = do+ zoom calendarL $ do+ cal <- get+ let config = calConfig cal+ newStyle = case config ^. dayLabelStyle of+ SingleChar -> DoubleChar+ DoubleChar -> DistinctInitials+ DistinctInitials -> SingleChar+ modify $ \s -> s { calConfig = config & dayLabelStyle .~ newStyle }++-- Cycle outside month display+handleEvent (VtyEvent (V.EvKey (V.KChar 'o') [])) = do+ zoom calendarL $ do+ cal <- get+ let config = calConfig cal+ newOutside = case config ^. outsideMonthDisplay of+ Hide -> ShowDimmed+ ShowDimmed -> ShowNormal+ ShowNormal -> Hide+ modify $ \s -> s { calConfig = config & outsideMonthDisplay .~ newOutside }++-- Toggle week start+handleEvent (VtyEvent (V.EvKey (V.KChar 'w') [])) = do+ zoom calendarL $ do+ cal <- get+ let config = calConfig cal+ newStart = case config ^. weekStart of+ Sunday -> Monday+ Monday -> Sunday+ _ -> 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 ()++-- | Main function+main :: IO ()+main = do+ -- Ensure unicode support+ hSetEncoding stdout utf8++ -- Run the app+ s <- initialState+ finalState <- defaultMain app s+ case calSelectedDay $ calendar finalState of+ Just day -> putStrLn $ "Selected date: " ++ showGregorian day+ Nothing -> putStrLn "No date selected"
+ programs/SimpleDemo.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Brick+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++-- App state with calendar+newtype AppState = AppState+ { calendar :: CalendarState+ }++-- Initialize the app state+mkCalendarState :: Day -> CalendarState+mkCalendarState day = + let (year, month, _) = toGregorian day+ config = defaultCalendarConfig+ { _showDayLabels = True+ , _dayLabelStyle = DistinctInitials+ , _outsideMonthDisplay = ShowDimmed+ , _weekStart = Sunday+ }+ in CalendarState year month (Just day) config++-- Main app definition+app :: App AppState e CalendarResource+app = App+ { appDraw = drawUI+ , appChooseCursor = showFirstCursor+ , appHandleEvent = handleEvent+ , appStartEvent = return ()+ , appAttrMap = const defaultCalendarAttrMap+ }++-- Draw the UI+drawUI :: AppState -> [Widget CalendarResource]+drawUI s = [C.center $ border $ padAll 1 $ renderCalendar (calendar s)]++-- Handle events+handleEvent :: BrickEvent CalendarResource e -> EventM CalendarResource 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 ()++-- Main function+main :: IO ()+main = do+ -- Ensure unicode support+ hSetEncoding stdout utf8+ + -- Get today's date and create initial state+ today <- utctDay <$> getCurrentTime+ let initialState = AppState { calendar = mkCalendarState today }+ + -- Run the app+ finalState <- defaultMain app initialState+ + -- Print the selected date when the app exits+ case calSelectedDay $ calendar finalState of+ Just day -> putStrLn $ "Selected date: " ++ showGregorian day+ Nothing -> putStrLn "No date selected"
+ src/Brick/Widgets/Calendar.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}++-- | This module provides a month calendar widget for Brick applications.+--+-- == Usage+--+-- The widget provides:+--+-- * A render function to display the calendar+-- * A set of actions for navigation (moveUp, moveDown, etc.)+-- * Configuration options+--+-- Applications should connect the provided actions to keyboard events in their event handlers.+-- Common navigation patterns include:+--+-- * Arrow keys: Use moveUp, moveDown, moveLeft, moveRight to navigate between days+-- * Month navigation: Use setMonthBefore, setMonthAfter to change months+-- * Year navigation: Use setYearBefore, setYearAfter to change years+--+-- When a navigation action is applied and no day is selected, the first day of the current month will be selected.+-- When navigating between days, if moving to a date outside the current month, the view will automatically+-- shift to that month.+module Brick.Widgets.Calendar+ ( -- * Render+ renderCalendar+ , CalendarState(..)++ -- * Actions+ , moveUp+ , moveDown+ , moveLeft+ , moveRight+ , setMonthBefore+ , setMonthAfter+ , setYearBefore+ , setYearAfter++ -- * Configuration+ , CalendarConfig(..)+ , DayLabelStyle(..)+ , OutsideMonthDisplay(..)+ , defaultCalendarConfig++ -- * Lenses+ , weekStart+ , dayLabelStyle+ , showDayLabels+ , outsideMonthDisplay+++ -- * Resource name+ , CalendarResource(..)++ -- * Utilities+ , getFirstDayOfMonth+ , getDayLabel+ , getMonthLabel+ , getWeekDayLabels+ , formatDate+ , defaultCalendarAttrMap+ ) where++import qualified Brick.AttrMap as A+import qualified Graphics.Vty as V+import Brick.Util (fg)++import Brick.Widgets.Calendar.Internal.Actions+import Brick.Widgets.Calendar.Internal.Core+import Brick.Widgets.Calendar.Internal.Month+import Brick.Widgets.Calendar.Internal.Utils++-- | Attribute map for calendar widgets.+defaultCalendarAttrMap :: A.AttrMap+defaultCalendarAttrMap = A.attrMap V.defAttr+ [ (A.attrName "calendar.day", fg V.white)+ , (A.attrName "calendar.day" <> A.attrName "selected", fg V.black `V.withBackColor` V.blue)+ , (A.attrName "calendar.outsideMonth", fg V.brightBlack)+ , (A.attrName "calendar.outsideMonth" <> A.attrName "selected", fg V.black `V.withBackColor` V.blue)+ , (A.attrName "calendar.hidden", V.currentAttr)+ , (A.attrName "calendar.nav", fg V.blue)+ , (A.attrName "calendar.header", V.defAttr `V.withStyle` V.bold)+ ]
+ src/Brick/Widgets/Calendar/Internal/Actions.hs view
@@ -0,0 +1,79 @@+module Brick.Widgets.Calendar.Internal.Actions+ ( moveUp+ , moveDown+ , moveLeft+ , moveRight+ , setMonthBefore+ , setMonthAfter+ , setYearBefore+ , setYearAfter+ ) where++import Data.Time+import Data.Time.Calendar.Month++import Brick.Widgets.Calendar.Internal.Core++moveUp :: CalendarState -> CalendarState+moveUp =+ navigateSelection (addDays (-7))++moveDown :: CalendarState -> CalendarState+moveDown =+ navigateSelection (addDays 7)++moveLeft :: CalendarState -> CalendarState+moveLeft =+ navigateSelection (addDays (-1))++moveRight :: CalendarState -> CalendarState+moveRight =+ navigateSelection (addDays 1)++setMonthBefore :: CalendarState -> CalendarState+setMonthBefore =+ navigateMonth (addMonths (-1))++setMonthAfter :: CalendarState -> CalendarState+setMonthAfter =+ navigateMonth (addMonths 1)++setYearBefore :: CalendarState -> CalendarState+setYearBefore =+ navigateMonth (addMonths (-12))++setYearAfter :: CalendarState -> CalendarState+setYearAfter =+ navigateMonth (addMonths 12)++navigateSelection :: (Day -> Day) -> CalendarState -> CalendarState+navigateSelection dayTransform s =+ case calSelectedDay s of+ Nothing -> + -- When no day is selected, select the first day of the current month+ s { calSelectedDay = Just $ fromGregorian (calYear s) (calMonth s) 1 }+ Just day ->+ let newDay = dayTransform day+ (y, m, _) = toGregorian newDay+ in if m /= calMonth s || y /= calYear s+ -- If we've moved to a different month, update the view+ then s { calYear = y, calMonth = m, calSelectedDay = Just newDay }+ -- Otherwise just update the selected day+ else s { calSelectedDay = Just newDay }++navigateMonth :: (Month -> Month) -> CalendarState -> CalendarState+navigateMonth monthTransform s = + let currentYM = YearMonth (calYear s) (calMonth s)+ newYM = monthTransform currentYM+ YearMonth newYear newMonth = newYM+ + -- Keep the same day if possible in the new month+ newDay = case calSelectedDay s of+ Nothing -> Nothing+ Just day -> + let (_, _, d) = toGregorian day+ lastDayInNewMonth = periodLength newYM+ adjustedDay = min d lastDayInNewMonth+ in Just $ fromGregorian newYear newMonth adjustedDay+ + in s { calYear = newYear, calMonth = newMonth, calSelectedDay = newDay }
+ src/Brick/Widgets/Calendar/Internal/Core.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++module Brick.Widgets.Calendar.Internal.Core+ ( -- * Types+ CalendarConfig(..)+ , DayLabelStyle(..)+ , OutsideMonthDisplay(..)+ , DateFormat(..)+ , CalendarState(..)+ , defaultCalendarConfig++ -- * Lenses+ , weekStart+ , dayLabelStyle+ , showDayLabels+ , outsideMonthDisplay+ , dateFormat++ -- * Resource name+ , CalendarResource(..)+ ) where++import Data.Time (DayOfWeek(..), Day)+import Lens.Micro.TH ( makeLenses )++-- | Style for displaying day labels.+data DayLabelStyle = + SingleChar -- ^ Use single characters: S M T W T F S+ | DoubleChar -- ^ Use two characters: Su Mo Tu We Th Fr Sa+ | DistinctInitials -- ^ Use single chars with Th for Thursday: S M T W Th F S+ deriving (Show, Eq)++-- | How to display days outside the current month.+data OutsideMonthDisplay =+ Hide -- ^ Don't show days outside current month+ | ShowDimmed -- ^ Show days outside month with dimmed styling+ | ShowNormal -- ^ Show days outside month with normal styling+ deriving (Show, Eq)++-- | Format options for displaying dates in the calendar.+data DateFormat =+ DefaultFormat -- ^ Use default format (%b %Y for month header, digits for days)+ | CustomFormat + { headerFormat :: String -- ^ Format string for month/year header (e.g., "%B %Y")+ , dayFormat :: String -- ^ Format string for days (e.g., "%d")+ } -- ^ Use custom format strings from Data.Time.Format (%a, %d, etc.)+ deriving (Show, Eq)++-- | Configuration for the calendar widget.+data CalendarConfig = CalendarConfig+ { _weekStart :: DayOfWeek -- ^ Day of week to start the calendar+ , _dayLabelStyle :: DayLabelStyle -- ^ Style for day labels+ , _showDayLabels :: Bool -- ^ Whether to show day labels at all+ , _outsideMonthDisplay :: OutsideMonthDisplay -- ^ How to display days outside current month+ , _dateFormat :: DateFormat -- ^ Format to use for dates+ } deriving (Show, Eq)++-- | Default calendar configuration.+defaultCalendarConfig :: CalendarConfig+defaultCalendarConfig = CalendarConfig+ { _weekStart = Sunday+ , _dayLabelStyle = SingleChar+ , _showDayLabels = True+ , _outsideMonthDisplay = ShowDimmed+ , _dateFormat = DefaultFormat+ }++-- | Resource name for calendar widget elements.+data CalendarResource =+ CalendarDay Int Int Int -- ^ Resource for a day (year, month, day)+ | CalendarMonth Int Int -- ^ Resource for month header (year, month)+ | CalendarPrev -- ^ Resource for previous month button+ | CalendarNext -- ^ Resource for next month button+ 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)++++makeLenses ''CalendarConfig
+ src/Brick/Widgets/Calendar/Internal/Month.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Brick.Widgets.Calendar.Internal.Month+ (+ renderCalendar+ ) where++import Brick+import Brick.Widgets.Center++import Data.Time+import Data.Time.Calendar.Month+import Lens.Micro++import Brick.Widgets.Calendar.Internal.Core+import Brick.Widgets.Calendar.Internal.Utils++-- | Render a month calendar widget+renderCalendar :: CalendarState -> Widget CalendarResource+renderCalendar state@CalendarState{..} =+ vBox [ renderHeader state+ , if calConfig ^. showDayLabels+ then renderDayLabels calConfig+ else emptyWidget+ , renderDays calConfig calYear calMonth calSelectedDay+ ]++-- | Render the calendar header with month/year and navigation buttons+renderHeader :: CalendarState -> Widget CalendarResource+renderHeader CalendarState{..} =+ let monthText = getMonthLabel calConfig calYear calMonth+ prevButton = clickable CalendarPrev $ + withAttr (attrName "calendar.nav") $ + str " << "+ monthLabel = clickable (CalendarMonth (fromIntegral calYear) calMonth) $ + txt monthText+ nextButton = clickable 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 config =+ let labels = getWeekDayLabels config+ -- Create evenly spaced day labels using padRight+ paddedLabels = init labels `zip` repeat (Pad 1) ++ [(last labels, Pad 0)]+ makeLabel (l, p) = padRight p $ + withAttr (attrName "calendar.dayLabel") $+ txt l+ in hBox $ map makeLabel paddedLabels++-- | Render the days of the month+renderDays :: CalendarConfig -> Integer -> Int -> Maybe Day -> Widget CalendarResource+renderDays config year month selectedDay =+ let yearMonth = YearMonth year month+ daysInMonth = periodLength yearMonth+ firstDay = getFirstDayOfMonth year month+ + -- Get days of previous month that need to be displayed+ prevYearMonth = addMonths (-1) yearMonth+ YearMonth prevYear prevMonth = prevYearMonth+ prevMonthDays = periodLength prevYearMonth+ + -- Calculate start day offset more elegantly using modular arithmetic+ -- This avoids nested case statements+ firstDayInt = fromEnum firstDay+ weekStartInt = fromEnum $ config ^. weekStart+ startDayNum = (firstDayInt - weekStartInt) `mod` 7+ + -- Days from previous month to display+ prevDays = + if startDayNum > 0+ then map (\d -> (prevYear, prevMonth, d, True)) + [prevMonthDays - startDayNum + 1 .. prevMonthDays]+ else []+ + -- Days from current month+ currentDays = map (\d -> (year, month, d, False)) [1..daysInMonth]+ + -- Calculate extra days needed from next month+ nextYearMonth = addMonths 1 yearMonth+ 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+ + -- Create next month days to fill exactly 6 rows+ nextDays = map (\d -> (nextYear, nextMonth, d, True)) [1..daysNeeded]+ + -- All days to display+ allDays = prevDays ++ currentDays ++ nextDays+ + -- Chunked into weeks (always 6 weeks)+ weeks = chunksOf 7 allDays+ + -- Render a single day with appropriate padding+ renderDay (dayInfo, isLast) =+ let (y, m, d, isOutside) = dayInfo+ day = fromGregorian y m d+ isSelected = maybe False (== day) selectedDay+ + -- Decide attribute based on whether day is outside current month+ attr = if isOutside + then case config ^. outsideMonthDisplay of+ Hide -> attrName "calendar.hidden"+ ShowDimmed -> attrName "calendar.outsideMonth"+ ShowNormal -> attrName "calendar.day"+ else attrName "calendar.day"+ + -- Add selected attribute if day is selected+ finalAttr = if isSelected + then attr <> attrName "selected"+ else attr+ + -- Format day as text+ dayText = if isOutside && config ^. outsideMonthDisplay == Hide+ then " " -- Two spaces for hidden days+ else formatDayNumber config day+ + -- Create clickable day widget with appropriate resource identifier+ baseDayWidget = clickable (CalendarDay (fromIntegral y) m d) $+ hLimit 3 $ withAttr finalAttr (txt dayText)+ + -- Add padding except for the last item in each row+ dayWidget = if isLast+ then baseDayWidget+ else padRight (Pad 1) baseDayWidget+ in dayWidget+ + -- Render a week by adding padding between days but not after the last one+ renderWeek days = + let daysWithIsLast = zip days (replicate 6 False ++ [True])+ in hBox $ map renderDay daysWithIsLast+ + in vBox $ map renderWeek weeks
+ src/Brick/Widgets/Calendar/Internal/Utils.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}++module Brick.Widgets.Calendar.Internal.Utils+ ( -- * Date helpers+ getFirstDayOfMonth+ , getDayLabel+ , getMonthLabel+ , getWeekDayLabels+ + -- * Date formatting+ , formatDate+ , formatDayNumber++ -- * List helpers+ , chunksOf+ ) where++import Data.Time+import Data.Time.Calendar.Month+import Data.Text (Text)+import qualified Data.Text as T+import Brick.Widgets.Calendar.Internal.Core+import Lens.Micro+import Data.List (elemIndex)+import Data.Maybe (fromMaybe)++-- | Split a list into chunks of a given size+chunksOf :: Int -> [a] -> [[a]]+chunksOf _ [] = []+chunksOf n xs = take n xs : chunksOf n (drop n xs)++-- | Get the day of week for the first day of the given month+getFirstDayOfMonth :: Integer -> Int -> DayOfWeek+getFirstDayOfMonth year month = + dayOfWeek $ fromGregorian year month 1++-- | Get the label for a day based on the day of week and label style+getDayLabel :: DayLabelStyle -> DayOfWeek -> Text+getDayLabel style dow = case (style, dow) of+ (SingleChar, Monday) -> "M "+ (SingleChar, Tuesday) -> "T "+ (SingleChar, Wednesday) -> "W "+ (SingleChar, Thursday) -> "T "+ (SingleChar, Friday) -> "F "+ (SingleChar, Saturday) -> "S "+ (SingleChar, Sunday) -> "S "+ + (DoubleChar, Monday) -> "Mo"+ (DoubleChar, Tuesday) -> "Tu"+ (DoubleChar, Wednesday) -> "We"+ (DoubleChar, Thursday) -> "Th"+ (DoubleChar, Friday) -> "Fr"+ (DoubleChar, Saturday) -> "Sa"+ (DoubleChar, Sunday) -> "Su"+ + (DistinctInitials, Monday) -> "M "+ (DistinctInitials, Tuesday) -> "T "+ (DistinctInitials, Wednesday) -> "W "+ (DistinctInitials, Thursday) -> "Th"+ (DistinctInitials, Friday) -> "F "+ (DistinctInitials, Saturday) -> "S "+ (DistinctInitials, Sunday) -> "Su"++-- | Get the month label as text (e.g., "Apr 2025")+getMonthLabel :: CalendarConfig -> Integer -> Int -> Text+getMonthLabel config year month =+ let m = YearMonth year month+ day = MonthDay m 1+ fmt = case config ^. dateFormat of+ DefaultFormat -> "%b %Y"+ CustomFormat{headerFormat=f} -> f+ in T.pack $ formatTime defaultTimeLocale fmt day++-- | Get the labels for all days of the week based on configuration+getWeekDayLabels :: CalendarConfig -> [Text]+getWeekDayLabels config =+ let startDay = config ^. weekStart+ style = config ^. dayLabelStyle+ allDays = [Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday]+ startIdx = fromMaybe 0 $ elemIndex startDay allDays+ -- Rotate the list so startDay is first+ weekDays = drop startIdx allDays ++ take startIdx allDays+ in map (getDayLabel style) weekDays++-- | Format a date as text using the configured format+formatDate :: CalendarConfig -> Day -> Text+formatDate config day = + let fmt = case config ^. dateFormat of+ DefaultFormat -> "%Y-%m-%d"+ CustomFormat{dayFormat=f} -> f+ in T.pack $ formatTime defaultTimeLocale fmt day++-- | Format a day number based on configuration (for calendar display)+formatDayNumber :: CalendarConfig -> Day -> Text+formatDayNumber config day =+ let (_, _, d) = toGregorian day+ fmt = case config ^. dateFormat of+ DefaultFormat -> T.justifyLeft 2 ' ' (T.pack $ show d)+ CustomFormat{dayFormat=f} -> T.pack $ formatTime defaultTimeLocale f day+ in fmt
+ test/Main.hs view
@@ -0,0 +1,112 @@+module Main where++import Test.Hspec+import Brick.Widgets.Calendar+import Data.Time++main :: IO ()+main = hspec $ do+ describe "Calendar Navigation" $ do+ let standardState year month day = + CalendarState year month (Just $ fromGregorian year month day) defaultCalendarConfig+ + describe "Directional Movement" $ do+ it "correctly moves selection up" $ do+ let initialState = standardState 2025 5 15+ let newState = moveUp initialState+ calSelectedDay newState `shouldBe` Just (fromGregorian 2025 5 8)+ + it "correctly moves selection down" $ do+ let initialState = standardState 2025 5 15+ let newState = moveDown initialState+ calSelectedDay newState `shouldBe` Just (fromGregorian 2025 5 22)+ + it "correctly moves selection left" $ do+ let initialState = standardState 2025 5 15+ let newState = moveLeft initialState+ calSelectedDay newState `shouldBe` Just (fromGregorian 2025 5 14)+ + it "correctly moves selection right" $ do+ let initialState = standardState 2025 5 15+ let newState = moveRight initialState+ calSelectedDay newState `shouldBe` Just (fromGregorian 2025 5 16)+ + describe "Month Navigation" $ do+ it "correctly navigates to previous month" $ do+ let initialState = standardState 2025 5 15+ let newState = setMonthBefore initialState+ calMonth newState `shouldBe` 4+ calYear newState `shouldBe` 2025+ + it "correctly navigates to next month" $ do+ let initialState = standardState 2025 5 15+ let newState = setMonthAfter initialState+ calMonth newState `shouldBe` 6+ calYear newState `shouldBe` 2025 ++ describe "Year Navigation" $ do+ it "correctly navigates to previous year" $ do+ let initialState = standardState 2025 5 15+ let newState = setYearBefore initialState+ calMonth newState `shouldBe` 5+ calYear newState `shouldBe` 2024++ it "correctly navigates to next year" $ do+ let initialState = standardState 2025 5 15+ let newState = setYearAfter initialState+ calMonth newState `shouldBe` 5+ calYear newState `shouldBe` 2026+ + describe "Edge Cases" $ do+ describe "Leap Year Handling" $ do+ it "correctly handles date selection in leap year" $ do+ let initialState = standardState 2024 2 28+ let newState = moveRight initialState+ calSelectedDay newState `shouldBe` Just (fromGregorian 2024 2 29)+ + it "correctly handles date selection across leap year boundary" $ do+ let initialState = standardState 2024 2 29+ let newState = moveRight initialState+ calSelectedDay newState `shouldBe` Just (fromGregorian 2024 3 1)+ calMonth newState `shouldBe` 3+ + it "correctly navigates from leap day to next month" $ do+ let initialState = standardState 2024 2 29+ let newState = setMonthAfter initialState+ calSelectedDay newState `shouldBe` Just (fromGregorian 2024 3 29)+ calMonth newState `shouldBe` 3+ calYear newState `shouldBe` 2024+ + it "correctly navigates from leap day to next year (non-leap year)" $ do+ let initialState = standardState 2024 2 29+ let newState = setYearAfter initialState+ calSelectedDay newState `shouldBe` Just (fromGregorian 2025 2 28)+ calMonth newState `shouldBe` 2+ calYear newState `shouldBe` 2025+ + describe "Year Boundary Handling" $ do+ it "correctly handles next month at year boundary" $ do+ let initialState = standardState 2025 12 15+ let newState = setMonthAfter initialState+ calMonth newState `shouldBe` 1+ calYear newState `shouldBe` 2026+ + it "correctly handles previous month at year boundary" $ do+ let initialState = standardState 2025 1 15+ let newState = setMonthBefore initialState+ calMonth newState `shouldBe` 12+ calYear newState `shouldBe` 2024+ + it "correctly handles next day at year boundary" $ do+ let initialState = standardState 2025 12 31+ let newState = moveRight initialState+ calSelectedDay newState `shouldBe` Just (fromGregorian 2026 1 1)+ calMonth newState `shouldBe` 1+ calYear newState `shouldBe` 2026+ + it "correctly handles previous day at year boundary" $ do+ let initialState = standardState 2025 1 1+ let newState = moveLeft initialState+ calSelectedDay newState `shouldBe` Just (fromGregorian 2024 12 31)+ calMonth newState `shouldBe` 12+ calYear newState `shouldBe` 2024